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

Hiç yorum yok:

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