Listboxa veri alma

[acar6783]

Biliyorum bu konuca yüzlerce sorucevap var ama.Yine de acmak zorundayım

Bir sayfadaki A sütunundaki verilerden hem "EntireRow.Hidden = False" olanı hem de Benzersiz olanları en hızlı şekilde nasıl alırım.

Kullanıdğım kod çok yavaş bu konuda.Aklıma Distinc ile almak geliyor ama onda da gizli olmayan satırları nasıl ayırt eeceğimi bilemedim

 

[Orion1]

Buyurun.

Dim sonsat As Long
ListBox1.RowSource = ""
Sheets("Sayfa2").Range("A:B").ClearContents
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:B" & sonsat).SpecialCells(xlCellTypeVisible).Copy Sheets("Sayfa2").Range("A1")
ListBox1.RowSource = "Sayfa2!A1:B" & Sheets("Sayfa2").Cells(Rows.Count, "A").End(xlUp).Row

 

[acar6783]

Buyurun.

Dim sonsat As Long
ListBox1.RowSource = ""
Sheets("Sayfa2").Range("A:B").ClearContents
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Range("A1:B" & sonsat).SpecialCells(xlCellTypeVisible).Copy Sheets("Sayfa2").Range("A1")
ListBox1.RowSource = "Sayfa2!A1:B" & Sheets("Sayfa2").Cells(Rows.Count, "A").End(xlUp).Row

Bu koşulu atlamışsınız sanırım.

hem de Benzersiz

Bunun için döngü hariç ne yapabiliriz?

 

[acar6783]

With Sayfa1
.Columns("AZ").ClearContents
 son = Sayfa2.Cells(Rows.Count, "A").End(3).Row + 1
For deg = 2 To son

If Sayfa2.Rows(deg).EntireRow.Hidden = False Then
a = a + 1

.Cells(a, "AZ") = Sayfa2.Cells(deg, "A")

End If

Next deg


 son2 = .Cells(Rows.Count, "AZ").End(3).Row

For deg2 = 2 To son2
If WorksheetFunction.CountIf(.Range("AZ2:AZ" & deg2), .Cells(deg2, "AZ")) = 1 Then

ListBox1.AddItem .Cells(deg2, "AZ")
End If
Next deg2
End With

Bu kodu kullandım bu da satır sayısı fazla olunca haliyle yavaş çalışıyor.

 

[Orion1]

Buyurun.
Verileri diziye aldığım için hızlı çalışır diye düşünüyorum.

Private Sub CommandButton1_Click()
Dim z As Object, myarr(), n As Long
Dim sonsat As Long, i As Long
ListBox1.Clear
sonsat = Cells(Rows.Count, "A").End(xlUp).Row
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 2, 1 To sonsat)
For i = 1 To sonsat
    If Rows(i).EntireRow.Hidden = False Then
        If Not z.exists(Cells(i, "A").Value) Then
            n = n + 1
            z.Add Cells(i, "A").Value, n
            myarr(1, n) = Cells(i, "A").Value
            myarr(2, n) = Cells(i, "B").Value
        End If
    End If
Next i
Set z = Nothing
ReDim Preserve myarr(1 To 2, n)
ListBox1.List = Application.Transpose(myarr)
Erase myarr
End Sub

 

[acar6783]

z.exists

Bu kod tekrar etmeyenleri mi alıyor?

 

[Orion1]

Bu kod tekrar etmeyenleri mi alıyor?

Tekrar etmeyenleri ve eğer tekrarı var ise onuda 1 kez alıyor.

 

[acar6783]

Teşekkürler.
Çalıştırdım daha hızlı olduğu kesin

 

[Orion1]

Teşekkürler.
Çalıştırdım daha hızlı olduğu kesin

Rica ederim.
İyi çalışmalar.

 

[acar6783]

Bu kodlar çoğu işlemde kullanılabiliyor.
redim -Set z = CreateObject("Scripting.dictionary")

Sizden ricam kodlardaki aşamaların ne anlama geldiğini acıklayabilirmisiniz.
Bu olayı tamamen çözmek istiyorum.

 

[Orion1]

Bu kodlar çoğu işlemde kullanılabiliyor.
redim -Set z = CreateObject("Scripting.dictionary")

Sizden ricam kodlardaki aşamaların ne anlama geldiğini acıklayabilirmisiniz.
Bu olayı tamamen çözmek istiyorum.

redim=dizinin boyutunu ve eleman sayısını boyutluyor.
Set z = Createobject("Scripting.dictionary" = scripting.dictionary nesnesi set ediliyor.

 

[acar6783]

Hayırlı akşamlar,
Burada listeyi a'dan z'ye sıralı halde nasıl alırız?

Dim z As Object, myarr(), n As Long
Dim sonsat As Long, i As Long
lstbx.Clear
sonsat = Cells(Rows.Count, 1).End(xlUp).Row
Set z = CreateObject("Scripting.dictionary")
ReDim myarr(1 To 1, 1 To sonsat)
For i = 2 To sonsat
    If Rows(i).EntireRow.Hidden = False Then
        If Not z.exists(Cells(i, 1).Value) Then
            n = n + 1
            z.Add Cells(i, 1).Value, n
            myarr(1, n) = Cells(i, 1).Value
      
        End If
    End If
Next i
Set z = Nothing

ReDim Preserve myarr(1 To 1, n)
lstbx.List = Application.Transpose(myarr)
Erase myarr