Çoklu lookup

[erdemzi]

Merhaba

Linkte yer alan örnek dosyada 1. sayfada kod numaraları ve isimler, 2. sayfada kod numarasına karşılık gelen sistem numaraları yer alıyor. Yapmak istediğimiz, isimleri her kod numarasında yer alan sistem numaralarının karşılığına yazdırmak, örnek çıktıda 3. sayfada eklendi. Şimdiden yardımcı olacaklara teşekkür ederim.

https://dosya.co/gvahgo1k6cjp/Örnek.xlsx.html

 

[Korhan Ayhan]

Merhaba,

1. Yöntem (Dictionary) ;

Option Explicit

Sub Listele_Dictionary()
    Dim s1 As Worksheet, s2 As Worksheet, wsRapor As Worksheet
    Dim d As Object, v1, v2, out(), r&, i&, j&
   
    Set s1 = Sheets("Sheet1")
    Set s2 = Sheets("Sheet2")
    On Error Resume Next
    Set wsRapor = ThisWorkbook.Sheets("Rapor")
    If wsRapor Is Nothing Then
        Set wsRapor = ThisWorkbook.Sheets.Add(After:=Sheets(2))
        wsRapor.Name = "Rapor"
    Else
        wsRapor.Cells.Clear
    End If
    On Error GoTo 0

    v1 = s1.Range("A2", s1.Cells(s1.Rows.Count, "A").End(3)).Resize(, 2).Value
    v2 = s2.Range("A2", s2.Cells(s2.Rows.Count, "A").End(3)).Resize(, 2).Value

    Set d = CreateObject("Scripting.Dictionary")
   
    ' Sayfa2 verilerini grupla
    For i = 1 To UBound(v2)
        If Not d.exists(v2(i, 1)) Then
            d(v2(i, 1)) = Array(v2(i, 2))
        Else
            Dim tmp: tmp = d(v2(i, 1))
            ReDim Preserve tmp(UBound(tmp) + 1)
            tmp(UBound(tmp)) = v2(i, 2)
            d(v2(i, 1)) = tmp
        End If
    Next

    ReDim out(1 To UBound(v1) * 10, 1 To 3)
   
    ' Sayfa1 verileriyle eşleşenleri yaz
    For i = 1 To UBound(v1)
        If d.exists(v1(i, 1)) Then
            For j = 0 To UBound(d(v1(i, 1)))
                r = r + 1
                out(r, 1) = v1(i, 1)
                out(r, 2) = d(v1(i, 1))(j)
                out(r, 3) = v1(i, 2)
            Next
        End If
    Next

    If r > 0 Then
        wsRapor.Range("A1").Resize(1, 3).Value = Array("Kod", "Sistem No", "Taraf")
        wsRapor.Range("A1").Resize(, 3).Font.Bold = True
        wsRapor.Range("A2").Resize(r, 3).Value = out
        wsRapor.Columns.AutoFit
    End If
           
    MsgBox "Veriler listelendi.", vbInformation
End Sub

2. Yöntem (ADO) ;

Sub Listele_ADO()
    Dim cn As Object, rs As Object
    Dim wsRapor As Worksheet, i As Long
  
    ' Sayfaları ayarla
    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
  
    On Error Resume Next
    Set wsRapor = ThisWorkbook.Sheets("Rapor")
    If wsRapor Is Nothing Then
        Set wsRapor = ThisWorkbook.Sheets.Add(After:=Sheets(2))
        wsRapor.Name = "Rapor"
    Else
        wsRapor.Cells.Clear
    End If
    On Error GoTo 0
  
    ' Bağlantı oluştur
    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
            "Data Source=" & ThisWorkbook.FullName & ";" & _
            "Extended Properties=""Excel 12.0;HDR=Yes;IMEX=1"";"
  
    ' SQL sorgusu: INNER JOIN ile eşleşenleri çek
    rs.Open "SELECT s1.[Kod], s2.[Sistem No], s1.[Taraf] " & _
            "FROM [Sheet1$A1:B] AS s1 " & _
            "INNER JOIN [Sheet2$A1:B] AS s2 " & _
            "ON s1.[Kod] = s2.[Kod]", cn

    ' Sonuçları yaz
    For i = 0 To rs.Fields.Count - 1
        wsRapor.Cells(1, i + 1).Value = rs.Fields(i).Name
    Next
  
    wsRapor.Range("A1").Resize(, 3).Font.Bold = True
    wsRapor.Range("A2").CopyFromRecordset rs
    wsRapor.Columns.AutoFit

    rs.Close: cn.Close
  
    MsgBox "Veriler listelendi.", vbInformation
End Sub

 

[erdemzi]

elinize sağlık, çok iyi çalıştı.