Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Nisan 2009 Cuma

Add a Blank Line Under The Non-Empty line And Transport Rows To The List


 'AddTools on UserForm1: Image1, Label1, label2, label3, ListBox1, CommandButton1
Option Explicit
Dim i As Single, No As Double
Dim Hücre As Range, Alan As Range

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD®]Add a Blank Line Under The Non-Empty line And Transport Rows To The List"
.width = 460
.height = 306
.BackColor = &H80000016
End With
With ListBox1
.ColumnCount = 2
.ColumnWidths = "42;389"
.Font.Size = 8
End With
Application.Visible = True
End Sub
Private Sub UserForm_Activate()
            On Error Resume Next
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
On Error Resume Next
Application.Visible = True
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
Call DoluSatırlarınAltınaBoşSatırAçma
Call ListeyeTaşıma
End Sub
Sub DoluSatırlarınAltınaBoşSatırAçma() '[Add a blank line under the non-empty line]
On Error Resume Next
Application.ScreenUpdating = False
Set Hücre = ThisWorkbook.Sheets("Sayfa1").Cells(2, 1)
i = 0
Do ((While Hücre.Offset(i).Value <> ""))
Hücre.Offset(i + 1).EntireRow.Insert Shift:=xlDown
i = i + 2
Application.ScreenUpdating = True
End Sub
Sub ListeyeTaşıma() '[Transport rows to the list]
On Error Resume Next
No = 0
Set Alan = Range(Cells(2, 1), Cells([A65536].End(xlUp).Row, 1))
With ListBox1
For Each Hücre In Alan
.AddItem Hücre.Value
.List(No, 1) = Hücre.Offset(0, 1)
No = No + 1
Next Hücre
End With
End Sub

Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara


Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul