Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Nisan 2009 Pazartesi

Active Cell Control in DataBase




'Module1

Option Explicit
Dim i As Single, ii As Single, No As Single, Adet As Double
Dim Hücre As Range, AktifHücre As Range, Sayfa As Worksheet
Dim Bulunan, Bakılan
Dim İlk As Variant
Dim Hafıza As New Collection

Sub HesapListesiHazırla()
On Error GoTo Durak1
Set Sayfa = Sheets("Sayfa1")
Adet = Range("A65536").End(xlUp).Row - 1
If Adet = 0 Then
Exit Sub
Else
For i = 1 To Adet
Bulunan = Sayfa.Range("A2:a65536").Cells(i, 1)
For Each Bakılan In Hafıza
If Bakılan = Bulunan Then
GoTo Durak2
End If
Next Bakılan
Durak1:
Hafıza.Add Bulunan
Durak2:
Next i
Adet = Hafıza.Count
AktifHücreTanımı Adet
End If
End Sub
Private Function AktifHücreTanımı(ByVal HesapAdet As Double) '[Active Cell Control in DataBase]
On Error GoTo Hata
Sayfa.[E2:G65536].ClearContents
For i = 1 To HesapAdet
No = Range("F65536").End(xlUp).Row + 1
Set AktifHücre = Cells(No, 5)
AktifHücre.Offset(0, 0) = Hafıza(i)
Set Hücre = Sayfa.[A:A].Find(AktifHücre, LookAt:=xlWhole)
If Not Hücre Is Nothing Then
İlk = Hücre.Address
ii = 0
Do
ii = ii + 1
AktifHücre(ii, 2) = Hücre(1, 2).Value
AktifHücre(ii, 3) = Hücre(1, 3).Value
Set Hücre = Sheets("Sayfa1").[A:A].FindNext(Hücre)
Loop Until İlk = Hücre.Address
End If
Next i
Hata:
End Function

10 Nisan 2009 Cuma

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




'UserForm1

 '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
Loop
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
.Clear
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

1 Nisan 2009 Çarşamba

Transport Non-Empty Rows To The List And Delete Blank Lines




'UserForm1

'Add Tools 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, ÖzelAlan As Range
Dim Bulunan As String

Private Sub UserForm_Initialize()
On Error Resume Next
With Me
.Caption = "[PBİD®]Transport Non-Empty Rows To The List And Delete Blank Lines"
.width = 460
.height = 289
.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ıListeyeTaşıma
Call BoşSatırlarıSilme
End Sub
Sub DoluSatırlarıListeyeTaşıma() '[Transport non-empty rows to the list]
On Error Resume Next
No = 0
Set Alan = Range(Cells(2, 1), Cells([A65536].End(xlUp).Row, 1))
Bulunan = Alan.Address
Set ÖzelAlan = Alan.SpecialCells(xlCellTypeConstants)
With ListBox1
.Clear
For Each Hücre In ÖzelAlan
.AddItem Hücre.Value
.List(No, 1) = Hücre.Offset(0, 1)
No = No + 1
Next Hücre
End With
End Sub
Sub BoşSatırlarıSilme() '[Delete Blank Lines]
On Error Resume Next
Set Alan = Range(Cells(2, 1), Cells([A65536].End(xlUp).Row, 2))
Bulunan = Alan.Address
Set ÖzelAlan = Alan.SpecialCells(xlCellTypeBlanks)
ÖzelAlan.Delete
End Sub

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

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