Listview penceresine kayıt aktarma ve veri süzme

Katılım
4 Mart 2011
Mesajlar
38
Excel Vers. ve Dili
Türkçe/2010
Arkadaşlar hızlı arama yaparken harflerin indeksli bir şekilde sıralanması ve süzülen verilerin toplamının Texbox'da yer almasını sağlayan kodu yazarsanız memnun olacağım.
 

Ekli dosyalar

Katılım
15 Haziran 2006
Mesajlar
3,704
Excel Vers. ve Dili
Excel 2003, 2007, 2010 (TR)
Merhabalar,

Ekteki örnek dosyayı inceleyiniz.



Kodların tamamı, UserForm1 kod modülüne kopyalanmalı.

Not : Runtime esnasında görünmese de; UserForm'a, 1 adet "ImageList1" adında ImageList nesnesi eklenmelidir.

Kod:
Option Explicit

Dim booIni As Boolean

Private Sub ComboBox1_Change()
    Call Lvw_Guncelle
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub TextBox1_Change()
    Call Lvw_Guncelle
End Sub

Private Sub UserForm_Initialize()
    Dim i As Integer
    
    booIni = True
    
    With ComboBox1
        For i = 2 To 7
            .AddItem Cells(1, i)
        Next i
        .ListIndex = 0
        .Style = fmStyleDropDownList
    
    End With
    
    With ListView1
        .FullRowSelect = True
        .Gridlines = True
        .View = lvwReport
        .Icons = ImageList1
        .SmallIcons = ImageList1
        With .ColumnHeaders
            For i = 2 To 7
                .Add , , Cells(1, i), Cells(1, i).Width
            Next i
        End With
    End With
    
    TextBox1.SetFocus
    
    Me.Caption = "Ara/Bul - www.excel.web.tr"
    
    booIni = False
    
    Call Lvw_Guncelle
    
End Sub

Private Sub Lvw_Guncelle()
    Dim oItm As ListItem
    Dim rngBul As Range
    Dim sAdr As String
    Dim aramaKriteri As Long
    
    Dim i As Integer
    Dim lStr As Long
    
    If booIni Then Exit Sub
    
    If CheckBox1 Then
        aramaKriteri = xlWhole
    Else
        aramaKriteri = xlPart
    End If
    
    If Len(TextBox1) > 0 Then
        With ListView1
            .ListItems.Clear
            Set rngBul = Columns(ComboBox1.ListIndex + 2). _
                         Find(TextBox1, LOOKAT:=aramaKriteri)
            If Not rngBul Is Nothing Then
                sAdr = rngBul.Address
                Do
                    lStr = rngBul.Row
                    Set oItm = .ListItems.Add(, , Cells(lStr, 2), 1, 1)
                    With oItm.ListSubItems
                        .Add , , Cells(lStr, 3)
                        .Add , , Cells(lStr, 4)
                        .Add , , Cells(lStr, 5)
                        .Add , , Cells(lStr, 6)
                        .Add , , Cells(lStr, 7)
                    End With
                    
                    Set rngBul = Columns(ComboBox1.ListIndex + 2). _
                                 FindNext(rngBul)
                
                Loop Until rngBul Is Nothing Or sAdr = rngBul.Address
            End If
        End With
    Else
        With ListView1
            .ListItems.Clear
            For i = 2 To Cells(65536, 2).End(xlUp).Row
                Set oItm = .ListItems.Add(, , Cells(i, 2), 1, 1)
                With oItm.ListSubItems
                    .Add , , Cells(i, 3)
                    .Add , , Cells(i, 4)
                    .Add , , Cells(i, 5)
                    .Add , , Cells(i, 6)
                    .Add , , Cells(i, 7)
                End With
            Next i
        End With
    End If
    
    If ListView1.ListItems.Count > 0 Then
        Label7.Caption = "SONUÇ : Kriterinize uyan, " & _
                          ListView1.ListItems.Count & " adet '" & ComboBox1 & _
                          "' verisi bulunmuştur"
    Else
        Label7.Caption = "SONUÇ : Kriterinize uygun '" & _
                         ComboBox1 & "' verisi bulunamamıştır"
    End If
    
    Set rngBul = Nothing

End Sub

.
 

Ekli dosyalar

Katılım
4 Mart 2011
Mesajlar
38
Excel Vers. ve Dili
Türkçe/2010
Ferhat Bey ilginize çok teşekkür ediyorum. Elinize gönlünüze sağlık, çok güzel olmuş. Ancak hızlı aramada sorun var. 'H' harfine bastığımda 'H' harfi ile başlayan isimlerin yanında diğer isimlerde filitrelemeye dahil oluyor. Bunu engelleyebilir miyiz?
 
Katılım
15 Haziran 2006
Mesajlar
3,704
Excel Vers. ve Dili
Excel 2003, 2007, 2010 (TR)
TextBox'a, "H" girdiğinizde, "H" ile başlayanlar değil, içeriğinde "H" olan tüm kayıtlar listelenir.

Örneğin "HA" yazdığınızda, hem HASAN'ın hem de PERİHAN'ın geldiğine dikkat edin.

Bunu istemiyor musunuz?

.
 
Katılım
4 Mart 2011
Mesajlar
38
Excel Vers. ve Dili
Türkçe/2010
Ferhat Hocam sizi saygıyla selamlıyorum;
Ben içerisinde H harfi olan değil, Örneğin; "A" harfi ile başlayan bir kayıt arıyorsam, ilk harfi "Aa" olan kayıtları, ve ardından girdiğim her harfin karşılığı olan kayıtları geritmesini istiyorum.

Ferhat Bey, VBA ile ilgili kodların öğretimini veren tavsiye edeceğiniz bir kitap var mı?
Saygılar sunarım.
 
Son düzenleme:
Katılım
15 Haziran 2006
Mesajlar
3,704
Excel Vers. ve Dili
Excel 2003, 2007, 2010 (TR)
Anladım.

Siz arama ile birlikte bir süzme işlemini de düşünüyorsunuz.

O zaman ekteki dosyayı inceleyiniz.

Şu satır,

Kod:
Set rngBul = Columns(ComboBox1.ListIndex + 2). _
             Find(TextBox1 , LOOKAT:=aramaKriteri)
Şu şekilde değiştirilmiştir.


Kod:
Set rngBul = Columns(ComboBox1.ListIndex + 2). _
             Find(TextBox1 [COLOR="Red"][B]& "*"[/B][/COLOR], LOOKAT:=aramaKriteri)
Ayrıca, Initialize esnasında, ChecjBox1'e True değeri atanmıştır. Siz de en alttaki Check'i hep tiklenmiş tutarsanız, istediğiniz işlem gerçekleşecektir.

Not : Kitabın iyisi kötüsü olmaz. Siz herhangi birinden başlayın. İllaki bir şeyler kaparsınız. Takıldığınız yerlerde, buraya sorun. Ezberden ziyade, işin mantığını kavramaya çalışın. Bu süreç, biraz uzun sürebilir aceleci olmayın.

.
 

Ekli dosyalar

cem yılmaz

Altın Üye
Katılım
23 Aralık 2006
Mesajlar
359
Excel Vers. ve Dili
Office365 TÜRKÇE
Altın Üyelik Bitiş Tarihi
20-10-2026
Merhabalar.
Bu çalışmayı kendi userform'uma ekledim ama kodlar aktif sayfada arama yapıyor. Peki şu sayfada arama yap kodunu nasıl ekleyebiliriz?

Private Sub Lvw_Guncelle()
Dim oItm As ListItem
Dim rngBul As Range
Dim sAdr As String
Dim aramaKriteri As Long

Dim i As Integer
Dim lStr As Long

If booIni Then Exit Sub

If CheckBox1 Then
aramaKriteri = xlWhole
Else
aramaKriteri = xlPart
End If

If Len(TextBox1) > 0 Then
With ListView1
.ListItems.Clear
Set rngBul = Columns(ComboBox1.ListIndex + 2).Find(TextBox1, LOOKAT:=aramaKriteri)
If Not rngBul Is Nothing Then
sAdr = rngBul.Address
Do
lStr = rngBul.Row
Set oItm = .ListItems.Add(, , Cells(lStr, 2), 1, 1)
With oItm.ListSubItems
.Add , , Cells(lStr, 3)
.Add , , Cells(lStr, 4)
.Add , , Cells(lStr, 5)
.Add , , Cells(lStr, 6)
.Add , , Cells(lStr, 7)
End With

Set rngBul = Columns(ComboBox1.ListIndex + 2).FindNext(rngBul)

Loop Until rngBul Is Nothing Or sAdr = rngBul.Address
End If
End With
Else
With ListView1
.ListItems.Clear
For i = 2 To Cells(65536, 2).End(xlUp).Row
Set oItm = .ListItems.Add(, , Cells(i, 2), 1, 1)
With oItm.ListSubItems
.Add , , Cells(i, 3)
.Add , , Cells(i, 4)
.Add , , Cells(i, 5)
.Add , , Cells(i, 6)
.Add , , Cells(i, 7)
End With
Next i
End With
End If

If ListView1.ListItems.Count > 0 Then
Label7.Caption = "SONUÇ : Kriterinize uyan, " & ListView1.ListItems.Count & " adet '" & ComboBox1 & "' verisi bulunmuştur"
Else
Label7.Caption = "SONUÇ : Kriterinize uygun '" & ComboBox1 & "' verisi bulunamamıştır"
End If

Set rngBul = Nothing

End Sub
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
"Combobox2" ekleyip
"UserForm_Initialize" (zaten vardır) altına
Kod:
[SIZE="2"]Private Sub UserForm_Initialize()
For j = 1 To Sheets.Count
ComboBox2.AddItem Sheets(j).Name
Next
'......
'......diğer kodlar
End Sub[/SIZE]
yeni;
Kod:
[SIZE="2"]Private Sub ComboBox2_Change()
If ComboBox2.Value = "" Then Exit Sub
For a = 0 To ComboBox2.ListCount - 1
If ComboBox2.Value = ComboBox2.List(a) Then x = 1
Next
If x = empty Then ComboBox2.Value = "": MsgBox "SAYFA ADINI LİSTEDEN SEÇİNİZ"
End Sub [/SIZE]
Aşağıdaki gibi olabilir.
Kod:
[SIZE="2"]Private Sub Lvw_Guncelle()
Dim oItm As ListItem
Dim rngBul As Range
Dim sAdr As String
Dim aramaKriteri As Long
Dim i As Integer
Dim lStr As Long
'................................
[COLOR="Red"]Dim s1 As Worksheet
If ComboBox2.Value = "" Then
[COLOR="Blue"]Set s1 = ActiveSheet[/COLOR]
Else
Set s1 = Sheets(ComboBox2.Value)
End If[/COLOR]
'................................
If booIni Then Exit Sub
If CheckBox1 Then
aramaKriteri = xlWhole
Else
aramaKriteri = xlPart
End If

If Len(TextBox1) > 0 Then
With ListView1
.ListItems.Clear
Set rngBul = [COLOR="Red"]s1.[/COLOR]Columns(ComboBox1.ListIndex + 2).Find(TextBox1, LOOKAT:=aramaKriteri)
If Not rngBul Is Nothing Then
sAdr = rngBul.Address
Do
lStr = rngBul.Row
Set oItm = .ListItems.Add(, , [COLOR="Red"]s1.[/COLOR]Cells(lStr, 2), 1, 1)
With oItm.ListSubItems
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(lStr, 3)
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(lStr, 4)
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(lStr, 5)
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(lStr, 6)
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(lStr, 7)
End With

Set rngBul = [COLOR="Red"]s1[/COLOR].Columns(ComboBox1.ListIndex + 2).FindNext(rngBul)
Loop Until rngBul Is Nothing Or sAdr = rngBul.Address
End If
End With
Else
With ListView1
.ListItems.Clear
For i = 2 To [COLOR="Red"]s1.[/COLOR]Cells(65536, 2).End(xlUp).Row
Set oItm = .ListItems.Add(, , [COLOR="Red"]s1.[/COLOR]Cells(i, 2), 1, 1)
With oItm.ListSubItems
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(i, 3)
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(i, 4)
.Add , , [COLOR="Red"]s1.[/COLOR]Cells(i, 5)
.Add , , [COLOR="Red"]s1[/COLOR].Cells(i, 6)
.Add , , [COLOR="Red"]s1[/COLOR].Cells(i, 7)
End With
Next i
End With
End If

If ListView1.ListItems.Count > 0 Then
Label7.Caption = "SONUÇ : Kriterinize uyan, " & ListView1.ListItems.Count & " adet '" & ComboBox1 & "' verisi bulunmuştur"
Else
Label7.Caption = "SONUÇ : Kriterinize uygun '" & ComboBox1 & "' verisi bulunamamıştır"
End If
Set rngBul = Nothing
End Sub[/SIZE]
 
Son düzenleme:

cem yılmaz

Altın Üye
Katılım
23 Aralık 2006
Mesajlar
359
Excel Vers. ve Dili
Office365 TÜRKÇE
Altın Üyelik Bitiş Tarihi
20-10-2026
cevabınız için teşekkür ederim Sn PLİNT. Ama initialize açılırken hata veriyor. Nerede yanlış yapıyor olabilirim.?
Private Sub UserForm_Initialize()

Dim i As Integer

booIni = True

With ComboBox1
For i = 2 To 7
.AddItem Cells(1, i)
Next i
.ListIndex = 0
.Style = fmStyleDropDownList

End With

With ListView1
.FullRowSelect = True
.Gridlines = True
.View = lvwReport
.Icons = ImageList1
.SmallIcons = ImageList1
With .ColumnHeaders
For i = 2 To 7
.Add , , Cells(1, i), Cells(1, i).Width
Next i
End With
End With

TextBox1.SetFocus

Me.Caption = "Ara/Bul - www.excel.web.tr"

booIni = False

Call Lvw_Guncelle

For j = 1 To Sheets.Count
ComboBox2.AddItem Sheets(j).Name
Next
End Sub
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Eğer mümkünse yukarıdaki örnek dosyayı indiremiyorum;
http://s3.dosya.tc/ adresine yükleyip indirme adresini verirmisiniz.

"UserForm_Initialize" altında
"Call Lvw_Guncelle" bölümü varmış alta alalım

Kod:
Private Sub UserForm_Initialize()
'....
'.......
For j = 1 To Sheets.Count
ComboBox2.AddItem Sheets(j).Name
Next
Call Lvw_Guncelle
End Sub
"Exit sub" yerine aşağıdaki kırmızı bölümü
(Önceki mesajdaki değişen gibi)
Kod:
Private Sub Lvw_Guncelle()
'...
'......
 Dim s1 As Worksheet
If ComboBox2.Value = "" Then
[COLOR="Red"]Set s1 = ActiveSheet[/COLOR]
Else
Set s1 = Sheets(ComboBox2.Value)
End If
'....
'....
 
Katılım
31 Aralık 2014
Mesajlar
1,845
Excel Vers. ve Dili
Excel 2010
Merhaba
Formunu uygulamak istediğiniz dosya ile sizin dosyadaki sayfalar tam olarak uyumlu değil.
Sizin dosyanıza göre uyarlamaya çalıştım; ek dosyayı deneyelim.
http://s3.dosya.tc/server10/8x0vqd/Kopya_DEPO_SAYIM.zip.html
"Arama formu" kod sayfası:
Kod:
[SIZE="2"]Private Sub CommandButton1_Click()
    Unload Me
End Sub

Private Sub ComboBox2_Change()
If ComboBox2.Value = "" Then Exit Sub
For a = 0 To ComboBox2.ListCount - 1
If ComboBox2.Value = ComboBox2.List(a) Then x = 1
Next
If x = Empty Then ComboBox2.Value = "": MsgBox "SAYFA ADINI LİSTEDEN SEÇİNİZ": Exit Sub
ComboBox1.Clear
Call UserForm_Initialize
End Sub

Private Sub TextBox1_Change()
Dim oItm As ListItem
Dim rngBul As Range
Dim sAdr As String
Dim aramaKriteri As Long
Dim i As Integer
Dim lStr As Long
'................................
Dim sf As Worksheet

If ComboBox2.Value = "" Then
Set sf = ActiveSheet
Else
Set sf = Sheets(ComboBox2.Value)
End If


If CheckBox1.Value = True Then
aramaKriteri = xlWhole
Else
aramaKriteri = xlPart
End If

If Len(TextBox1) > 0 Then
If ComboBox1.Value = "" Then MsgBox "KRİTER SEÇİNİZ": TextBox1 = "": Exit Sub
With ListView1
.ListItems.Clear
Set rngBul = sf.Columns(ComboBox1.ListIndex + 1).Find(TextBox1.Text, LookIn:=xlValues, LOOKAT:=aramaKriteri)
If Not rngBul Is Nothing Then

sAdr = rngBul.Address
Do
lStr = rngBul.Row
'If LCase(rngBul) Like LCase("*" & TextBox1.Text & "*") Then
ListView1.ListItems.Add , , sf.Cells(lStr, 1).Value
y = .ListItems.Count
For a = 2 To 7
.ListItems(y).ListSubItems.Add , , sf.Cells(lStr, a).Value
Next
'End If:
Set rngBul = sf.Columns(ComboBox1.ListIndex + 1).FindNext(rngBul)
Loop Until rngBul Is Nothing Or sAdr = rngBul.Address
End If:
End With
Else
Call UserForm_Initialize
End If
If ListView1.ListItems.Count > 0 Then
If Trim(ListView1.ColumnHeaders(1).Text) = Trim(ListView1.ListItems(1).Text) Then ListView1.ListItems.Remove (1)

Label7.Caption = "SONUÇ : Kriterinize uyan, " & ListView1.ListItems.Count & " adet '" & ComboBox1 & "' verisi bulunmuştur"
Else
Label7.Caption = "SONUÇ : Kriterinize uygun '" & ComboBox1 & "' verisi bulunamamıştır"
End If
Set rngBul = Nothing
End Sub

Private Sub UserForm_Initialize()
Dim j, i As Integer
Dim f, n, y
Dim sf As Worksheet
If ComboBox2.Value <> "" Then
Set sf = Sheets(ComboBox2.Value)
Else
Set sf = ActiveSheet
End If
ListView1.ListItems.Clear: ListView1.ColumnHeaders.Clear
With ListView1
.View = lvwReport: .Gridlines = True: .FullRowSelect = True: .ListItems.Clear
For sat = 1 To 10
If sf.Cells(sat, 2) <> "" Then Exit For
Next
For a = 1 To 7
f = (sf.Columns(a).ColumnWidth - ((sf.Columns(a).ColumnWidth / 10) * 1.5)) * 8 '4.43
.ColumnHeaders.Add , , sf.Cells(sat, a) & " ", f
Next
End With
ComboBox1.Clear
With ComboBox1
For i = 1 To 7
.AddItem sf.Cells(sat, i)
Next i
.ListIndex = 0
.Style = fmStyleDropDownList
End With
n = 1
If sf.Cells(Rows.Count, 1).End(3).Row < 2 Then n = 2

For i = sat + 1 To sf.Cells(Rows.Count, n).End(xlUp).Row
ListView1.ListItems.Add , , sf.Cells(i, 1).Value
y = ListView1.ListItems.Count
For a = 2 To 7
ListView1.ListItems(y).ListSubItems.Add , , sf.Cells(i, a).Value
Next
Next i
TextBox1 = ""
    TextBox1.SetFocus
    Me.Caption = "Ara/Bul - www.excel.web.tr"
If ComboBox2.ListCount > 0 Then Exit Sub
    ComboBox2.Clear
For j = 1 To Sheets.Count
ComboBox2.AddItem Sheets(j).Name
Next
End Sub[/SIZE]
 
Son düzenleme:

cem yılmaz

Altın Üye
Katılım
23 Aralık 2006
Mesajlar
359
Excel Vers. ve Dili
Office365 TÜRKÇE
Altın Üyelik Bitiş Tarihi
20-10-2026
Yardımlarınız için teşekkür ederim sağolun.
 
Üst