• Foruma hoş geldin 👋 Ziyaretçi

    Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı ya da giriş yapmalısınız. Foruma üye olmak tamamen ücretsizdir.

    Giriş yap veya Şimdi kayıt ol

Arşiv ListView Sütuna göre Arama Çoklu Seçi

txtKaytSay = say döngünün dışına yazmışım o nedenle sorun çıkmış)
kod aşağıdaki gibi değişirse düzelir
Kod: 
 txtKaytSay = say
  If say = 0 Then
        MsgBox "Kayıt bulunamadı"
        For x = 0 To 8
            Controls("txt" & CStr(x)) = ""
        Next x
    Else
        Set DctLstV = dict
            KaydaGit (1)
    End If
 
Son düzenleme:
bu da excelin filtreleme özelliği kullanılarak yapıldı arama daha doğru ve hızlı gibi
125 bin satırdan fazla veri olduğundan listviewin yüklenmesi 25 saniyeyi buluyor
formda en baştaki Const xSyf As String = "CUSTOMERS" değeri Const xSyf As String = "CUSTOMERS2" olarak değiştirilirse sadece 1500 veri üzerinde işlem yapar
hatalar olabilir asıl amaç temel işlemlerin nasıl yapıldığını göstermek olduğundan gerisini kullanıcılar ihtiyaçlarına göre değiştirebilir
Filtre ile Arama Kodu
Kod: 
Sub xAraFilter()
Dim Syf As Worksheet
Dim RngF As Range
Dim Cll As Range
Dim MtnAra As String
Dim dict As New Dictionary
If Len(Me.TextBox1 & "") = 0 Then MsgBox "aranacak metin girilmedi!": Exit Sub
t1 = Timer
MtnAra = CStr(TextBox1.Text)
say = 0
Set Syf = ThisWorkbook.Worksheets(xSyf)
Syf.AutoFilterMode = False
SonC = Syf.Cells(Syf.Rows.Count, "A").End(xlUp).Row
       Syf.Range("A1:H" & SonC).AutoFilter Field:=CbStn, Criteria1:=MtnAra
sonD = Syf.Cells(Syf.Rows.Count, "A").End(xlUp).Row
If sonD < 2 Then GoTo 10
Set RngF = Syf.Range("A2:A" & SonC).SpecialCells(xlCellTypeVisible)
For Each Cll In RngF
    say = say + 1
    dict.Add say, Cll.Row - 1
Next Cll
    txtKaytSay = say
10
Syf.AutoFilterMode = False
    If say = 0 Then
        MsgBox "Kayıt bulunamadı"
        For x = 0 To 8
            Controls("txt" & CStr(x)) = ""
        Next x
    Else
        Set DctLstV = dict
            KaydaGit (1)
    End If
t2 = Timer
Debug.Print "Filtre : ", (t2 - t1) ' * 100
End Sub
Güncelleme kod listviewdeki satırı silip eklemeden
Kod: 
Sub xGuncelle()
Dim ws As Worksheet
With ListView1
ySr = .SelectedItem.Index
xSr = .ListItems(ySr).SubItems(8)
Set ws = ThisWorkbook.Worksheets(xSyf)
        For x = 0 To 8
            If x = 0 Then .ListItems(ySr).Text = Controls("txt" & CStr(x)) Else .ListItems(ySr).SubItems(x) = Controls("txt" & CStr(x))
            If x = 8 Then Exit For
            If x = 0 Then ws.Cells(xSr, x + 1) = CLng(Controls("txt" & CStr(x))) Else ws.Cells(xSr, x + 1) = Controls("txt" & CStr(x))
        Next x
End With
'__________________________________
        ListView1.ListItems(ySr).Selected = True
        ListView1.ListItems(ySr).EnsureVisible
        ListView1.SetFocus
End Sub

ListView_Ara_Git_Ekle_Sil_hy4.xlsm

drive.google.com drive.google.com
 
Son düzenleme:
Birde finditem ileydi asıl konu döngü ile yapmışsınız bu arada.
Finditem daha hızlı olur diye düşünüyordum abey.
 
Refaz' Alıntı:
finditem ileydi asıl konu döngü ile yapmışsınız
Genişletmek için tıkla...
zafer hocam listview ile ilgili aklıma gelen her yöntemi kullandığım örnekleri ekledim, aralarında finditem da var for each de tüm arananı seçme de var arananlar arasında dolaşmak da...
her kesin ihtiyacı, dosya yapısı farklı dolayısıyla gerisi kişiye kalmış, çalışmasına en uygun hangi yöntemse ona uygun kodların bleşkesini kullanabilir.
Not: emin değilim ama galiba finditem sadece ana sütundaki veriler için kısmı eşleşmeyi buluyor, tag yada subitem için tamm eşleşmeyi kabul etmiyor daha doğrusu whole da olsa partial da tam eşleşme olmayınca bulmuyor o nedenle like/instr gibi yan yollara başvurdum. Ama belirttiğim gibi tam emin değilim belki gözümden kaçan bir şey oldu o nedenle bulamadım
 
halily' Alıntı:
zafer hocam listview ile ilgili aklıma gelen her yöntemi kullandığım örnekleri ekledim, aralarında finditem da var for each de tüm arananı seçme de var arananlar arasında dolaşmak da...
her kesin ihtiyacı, dosya yapısı farklı dolayısıyla gerisi kişiye kalmış, çalışmasına en uygun hangi yöntemse ona uygun kodların bleşkesini kullanabilir.
Not: emin değilim ama galiba finditem sadece ana sütundaki veriler için kısmı eşleşmeyi buluyor, tag yada subitem için tamm eşleşmeyi kabul etmiyor daha doğrusu whole da olsa partial da tam eşleşme olmayınca bulmuyor o nedenle like/instr gibi yan yollara başvurdum. Ama belirttiğim gibi tam emin değilim belki gözümden kaçan bir şey oldu o nedenle bulamadım
Genişletmek için tıkla...
Tamam abey elinize sağlık.
Tam eşleşme oluyor çünkü mesela textboxtakine eşitse kodu olunca listviewin eli mahkum mecbur eşit olanı bulacak :)
Listview fazla verilerde gereksiz ama 10bin veriye kadar kullanılabilir abey.
 
Kod: 
Dim xSr As Long
Dim DctLstV As Dictionary
Const xSyf  As String = "CUSTOMERS2"
Kod: 
Private Sub UserForm_Initialize()
LstVDoldur
With Me.CbStn
BasSay = Me.ListView1.ColumnHeaders.Count - 1

Dim Stn() As Variant
ReDim Stn(BasSay, 1)
For x = 0 To BasSay
    Stn(x, 0) = x
    Stn(x, 1) = ListView1.ColumnHeaders(x + 1)
Next x
    .List = Stn
    .ListIndex = 2
End With
Me.ListView1.FullRowSelect = True
End Sub
Kod: 
Sub LstVDoldur()
t1 = Timer
Application.ScreenUpdating = False
Dim lst As ListItem
Dim SonStr As Long
Dim ws As Worksheet
Dim Rng As Range
Dim Cll As Range
ListView1.ListItems.Clear

Set ws = ThisWorkbook.Worksheets(xSyf)
SonStr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
         ListView1.View = lvwReport
    With ListView1.ColumnHeaders '.ColumnHeaders(13).Width = 100
    For xHdr = 1 To 8
        .Add , , ws.Cells(1, xHdr) ', 55, lvwColumnLeft
    Next xHdr
    End With
With ListView1
BasSay = .ColumnHeaders.Count - 1
Set Rng = ws.Range("A2:H" & SonStr)
For Each Cll In Rng
    If Cll.Column = 1 Then Set lst = .ListItems.Add(Text:=Cll.Value) Else lst.SubItems(Cll.Column - 1) = Cll.Value
Next Cll
    .ColumnHeaders(1).Width = 60
    .ColumnHeaders(2).Width = 100
    .ColumnHeaders(3).Width = 100
    .ColumnHeaders(4).Width = 40
    .ColumnHeaders(5).Width = 70
    .ColumnHeaders(6).Width = 90
    .ColumnHeaders(7).Width = 100
    .ColumnHeaders(8).Width = 100
End With
Set ws = Nothing
Set lst = Nothing
Application.ScreenUpdating = True
t2 = Timer
Debug.Print "forEach liste doldur: " & t2 - t1, ListView1.ListItems.Count
End Sub
Kod: 
Sub xAra()
t1 = Timer

Dim MtnAra As String
Dim dict As New Dictionary

If Len(Me.TextBox1 & "") = 0 Then MsgBox "aranacak metin girilmedi!": Exit Sub
Dim itm As ListItem

MtnAra = CStr(TextBox1.Text)
MtnAra = UCase(Replace(Replace(MtnAra, Chr(105), Chr(221)), Chr(73), Chr(253)))

say = 0
With Me.ListView1
    .MultiSelect = False
    .ListItems(1).Selected = True
    .ListItems(1).Selected = False

For Each itm In .ListItems
If CbStn = 0 Then k = itm Else k = itm.SubItems(CbStn)
k = UCase(Replace(Replace(k, Chr(105), Chr(221)), Chr(73), Chr(253))) ' Replace(Replace(MtnAra, "i", "İ"), "I", "ı")
    If k Like MtnAra Then
        say = say + 1
        dict.Add say, itm.Index
    End If
Next itm
End With
txtKaytSay = say
    If say = 0 Then
        MsgBox "Kayıt bulunamadı"
        For x = 0 To 7
            Controls("txt" & CStr(x)) = ""
        Next x
    Else
        Set DctLstV = dict
        KaydaGit (1)
    End If

t2 = Timer

Debug.Print "For Each : ", (t2 - t1) ' * 100
End Sub
Kod: 
Sub KaydaGit(xSr As Long)
If xSr < 0 Or txtKaytSay = 0 Then MsgBox "kayıt yok": Exit Sub
ySr = DctLstV(xSr)
        ListView1.ListItems(ySr).Selected = True
        ListView1.ListItems(ySr).EnsureVisible
        For x = 0 To 7
            If x = 0 Then Controls("txt" & CStr(x)) = ListView1.ListItems(ySr) Else Controls("txt" & CStr(x)) = ListView1.ListItems(ySr).SubItems(x)
        Next x
        txtIndX = xSr
        ListView1.SetFocus
End Sub
Kod: 
Private Sub BtnEkle_Click()
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(xSyf)
SonStr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 1
xMax = Application.WorksheetFunction.Max(ws.Range("A:A")) + 1

With ListView1
    For x = 0 To 7
        If x = 0 Then Set lst = .ListItems.Add(Text:=xMax) Else lst.SubItems(x) = Controls("txt" & CStr(x))
        If x = 0 Then ws.Cells(SonStr, x + 1) = xMax Else ws.Cells(SonStr, x + 1) = Controls("txt" & CStr(x))
    Next x
End With
Me.txt0 = xMax
End Sub
Kod: 
Private Sub BtnSil_Click()
If Len(Me.txt0 & "") = 0 Then MsgBox "Kayıt seçilmedi": Exit Sub
Dim ws As Worksheet
Dim Rng As Range
Dim c As Range

Set ws = ThisWorkbook.Worksheets(xSyf): SonStr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set Rng = ws.Range("A2:A" & SonStr)
Set c = Rng.Find(txt0.Text, , xlValues, xlWhole, xlByRows): xSr = c.Row
ySr = ListView1.SelectedItem.Index

ListView1.ListItems.Remove (ySr)
ws.Rows(xSr).EntireRow.Delete
        
    For x = 0 To 7
        Controls("txt" & CStr(x)) = ""
    Next x
End Sub
Kod: 
Sub xGuncelle()
Dim ws As Worksheet
Dim c As Range
Set ws = ThisWorkbook.Worksheets(xSyf)
SonStr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
Set Rng = ws.Range("A2:A" & SonStr)

With ListView1
ySr = .SelectedItem.Index
Set c = Rng.Find(txt0.Text, , xlValues, xlWhole, xlByRows)
xSr = c.Row
        For x = 1 To 7
             .ListItems(ySr).SubItems(x) = Controls("txt" & CStr(x))
                    ws.Cells(xSr, x + 1) = Controls("txt" & CStr(x))
        Next x
End With
        ListView1.ListItems(ySr).Selected = True
        ListView1.ListItems(ySr).EnsureVisible
        ListView1.SetFocus
End Sub
Kod: 
Private Sub ListView1_Click()
ySr = ListView1.SelectedItem.Index
        For x = 0 To 7
            If x = 0 Then Controls("txt" & CStr(x)) = ListView1.ListItems(ySr) Else Controls("txt" & CStr(x)) = ListView1.ListItems(ySr).SubItems(x)
        Next x
End Sub
 

Ekli dosyalar

halily' Alıntı:
UCase(Replace(Replace(MtnAra, Chr(105), Chr(221)), Chr(73), Chr(253))
Genişletmek için tıkla...
Önceden bunu söylemek istemiştim büyüki ve büyük ı vb.. için.
Aslında birde galiba strcomp gibi bişey vardı = 1 olarak if şartı ile kullanılıyordu harf duyarlılığı için abey.
Birde onunla yaparsanız tam olur :)
 
* ve ? Kullanabilmek için en uygunu like ;
instr yada StrComp'ta bildiğim kadarıyla * ve ? kullanılamaz,
StrComp sıralama yaparken işe yarar da aramalarda like kadar işlevsel değil bence
 
Son düzenleme:
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst