Koşula bağlı veri listelemek

[muhmayar]

Merhaba,

Bir listem var. Bu listede kategori, şehir, adı soyadı sütunları bulunuyor. Veriler bunlar. Ayrı bir sayfada, özet bir görünüm oluşturmak istiyorum. kategori ve şehir belirttiğim zaman bu şartları sağlayan isimlerin gelmesini sağlamam gerekli. Nasıl yapılabilir? Yardımınızı rica ediyorum. Teşekkür ederim.

 

[Vedat Özer]

Merhabalar,

Aşağıdaki kodları boş bir modül oluşturup içine yapıştırıp deneyin.

Not: Kodları kontrol etme fırsatım olmadı.

Sub Liste_AL()
Dim c As Range, sat As Long, ilkadres As Variant
Sheets("Özet").Range("E4:F50000").ClearContents

Application.Calculation = xlManual
sat = 4
With Sheets("Veri").Range("C:C")
Set c = .Find(Sheets("Özet").Range("C4"), LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
ilkadres = c.Address
Do
If Sheets("Veri").Cells(c.Row, "B") = Range("B4") Then

Cells(sat, "e") = sat - 3

Sheets("Özet").Cells(sat, "f") = Sheets("Veri").Cells(c.Row, "c")
Sheets("Özet").Cells(sat, "g") = Sheets("Veri").Cells(c.Row, "d")
sat = sat + 1
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> ilkadres
End If
End With

Application.Calculation = xlAutomatic

MsgBox " İşlem Tamamlandı", vbInformation
End Sub

 

[muhmayar]

Çok teşekkür ederim Vedat Bey. Listede şehir ismini de getirdi kodlar. Sorun sayılmaz zira kodlara bakıp çözülebilir bu durum.
Ancak kodlar excelde yavaşlama oluşturuyor. Bunu formüller ile sağlayamaz mıyız, esas aradığım bu aslında.

 

[Orion1]

Formüllerde dahada yavaşlar.
alternatif;
Dosyanız ektedir.

Option Base 1
Sub arabul59()
Dim sh As Worksheet, sonsat As Long, i As Long, liste(), myarr(), n As Long
Sheets("Özet").Select
Set sh = Sheets("Veri")
Range("E4:F" & Rows.Count).ClearContents
sh.Range("A1:D1").AutoFilter
sonsat = sh.Cells(Rows.Count, "D").End(xlUp).Row
liste = sh.Range("A2:D" & sonsat).Value
ReDim myarr(1 To 2, 1 To sonsat - 1)
For i = 1 To UBound(liste)
    If liste(i, 2) = Cells(4, "B").Value And liste(i, 3) = Cells(4, "C").Value Then
        n = n + 1
        myarr(1, n) = liste(i, 1)
        myarr(2, n) = liste(i, 4)
    End If
Next i
Erase liste
Application.ScreenUpdating = False
If n > 0 Then
    ReDim Preserve myarr(1 To 2, 1 To n)
    Range("E4").Resize(n, 2) = Application.Transpose(myarr)
End If
Erase myarr: Set sh = Nothing
Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı." & vbLf & "evrengizlen@hotmail.com"
End Sub

 

[muhmayar]

Çok teşekkür ederim Evren Bey. Aklınıza sağlık. Kod yazım tekniğinize gıpta ediyorum. İyi çalışmalar.

 

[Orion1]

Çok teşekkür ederim Evren Bey. Aklınıza sağlık. Kod yazım tekniğinize gıpta ediyorum. İyi çalışmalar.

Rica ederim.
iyi çalışmalar.