İki kritere göre verileri listeleme

[Karamanli.70]

Değerli hocalarım herkese hayırlı cumalar ve hayırlı ramazanlar diliyorum. Ben sağlık müdürlüğünde personel biriminde görev yapıyorum. Ekte yer alan listemde 2 sekmede bulunan birim ve ünvan kodlarına göre 1. sekmedeki verileri arayıp yine 2. sekmede yer alan sütunlara ilgili değerleri getiren bir VBA koda ihtiyacım var. Ben biraz bir şeyler yapmaya çalıştım ama yazdığım kod sadece tek sütuna verileri (2. sekmede ki 3. sütuna /std) getiriyor ve hatalı işlem yapıyor.

Bana yardımcı olursanız sevinirim. Şimdiden teşekkür ederim.


Sub VeriAraVeYaz()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim veriRng1 As Range, veriRng2 As Range
Dim kriterRng1 As Range, kriterRng2 As Range, yazRng As Range
Dim veri1 As Range, veri2 As Range
Dim kriter1 As Range, kriter2 As Range
Dim i As Integer

Set ws1 = ThisWorkbook.Sheets("1")
Set ws2 = ThisWorkbook.Sheets("2")

Set veriRng1 = ws1.Range("a2:a800")
Set veriRng2 = ws1.Range("b2:b800")

Set kriterRng1 = ws2.Range("a3:a19")
Set kriterRng2 = ws2.Range("b3:b19")
Set yazRng = ws2.Range("c3:c19")

For Each kriter1 In kriterRng1
For Each kriter2 In kriterRng2
For Each veri1 In veriRng1
For Each veri2 In veriRng2
If veri1.Value = kriter1.Value Or veri2.Value = kriter1.Value Or _
veri1.Value = kriter2.Value Or veri2.Value = kriter2.Value Then
i = i + 1
yazRng.Cells(i, 1).Value = ws1.Cells(veri1.Row, 13).Value
End If
Next veri2
Next veri1
Next kriter2
Next kriter1

MsgBox "Veriler başarıyla kopyalandı!", vbInformation
End Sub

 

[DoğanD]

Merhaba,

Almak istediğiniz verilerinizin tümü sayı. Dolayısıyla daha kolay yoldan ÇokEtopla formülü ile işinizi çözebilirsiniz. Kurduğunuz döngü çok uzun süreceği gibi "If" satırının da hatalı olduğunu düşünüyorum. Yani, kıyaslamanızda sadece Or (yada) kullanmışsınız. Bu işlev, kıyaslarınızın herhangi biri doğru olduğunda çalışacak ve iki kritere aynı anda bakmayacaktır. Bunun yerine And (ve) kullanmalısınız. Fakat bu durumda dahi bu tip bir işlemi döngü yerine formülle çözmek çok daha kolay ve hızlıdır. Verilerinizin içeriğini tam olarak anlamamakla birlikte, Çoketopla yada Topla.Çarpım formüllerini araştırmanızı öneririm.

Sonucu tek bir sütuna yazmasının sebebi de Set yazRng = ws2.Range("c3:c19") kodu. Yazdırılacak alanı sadece C sütunu olarak belirlemişsiniz.

 

[Karamanli.70]

Doğan hocam teşekkür ederim. Benim bu listem genel çalıştığım bir dosyanın sadece 2 sekmesi. Formülle yapabilirdim ama formül, mevcut dosyayı şişirip, kasar düşüncesi ile VBA kod ile halletmek istedim. Ayrıca VBA kodda AND ile denedim ama yine sıkıntılı oldu.

 

[DoğanD]

Merhaba tekrar,

Ekteki dosyayı inceler misiniz? Bu dosya siz görmeden ÇokEtopla uyguluyor ve formülü kaldırıyor. Döngüler nispeten daha yavaş çalışacağı için bu yol ile yaptım. En önemli nokta her iki alandaki sütun başlıklarının aynı olması. Dosya bu sayede hangi veriyi toplayacağını biliyor. Fazladan bir boşluk dahi hataya sebep olabilir. Mümkün olan her koşulu test ettikten sonra aktif kullanmanızı öneririm.

Sub VeriAl()
Dim i As Integer
Dim y As Variant
Application.ScreenUpdating = False
For i = 3 To Sayfa2.Cells(2, Columns.Count).End(1).Column
If WorksheetFunction.CountIf(Sayfa1.Range("1:1"), Sayfa2.Cells(2, i)) = 0 Then GoTo atla
y = Left(Columns(i).Address(0, 0), 1)
   Sayfa2.Cells(3, i).FormulaR1C1 = "=SUMIFS('1'!C" & WorksheetFunction.Match(Sayfa2.Cells(2, i), Sayfa1.Range("1:1"), 0) & ",'1'!C2,'2'!RC2,'1'!C1,'2'!RC1)"
   Sayfa2.Cells(3, i).AutoFill Sayfa2.Range(y & "3:" & y & Sayfa2.Range("A" & Rows.Count).End(xlUp).Row)
atla:
Next i
Sayfa2.Range("3:" & Range("A" & Rows.Count).End(xlUp).Row).Copy
Sayfa2.Range("3:" & Range("A" & Rows.Count).End(xlUp).Row).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

 

[Karamanli.70]

Çok teşekkür ederim ellerinize sağlık tam istediğim gibi oldu Doğan Hocam.