İKİ FARKLI Ç.KİTABINDAKİ VERİYİ KOŞULA GÖRE EŞLEŞTİRME HK

[bkk]

Merhabalar, elimde iki tane çalışma kitabı vardır, a çalışma kitabındaki tarih,2 ve 3 sütunları, b kitabındaki tarih ,x ve y sütunları ile eşleştiği takdirde,
a kitabında adet sütunundaki sayı kadar satırı çoğaltıp, b sütununda eşlesen farklı isimleri yan sütuna getirmelidir. Sonuç c kitabında örneklidir, Konu hakkında yardımcı olabilir misiniz? Teşekkür ederim

 

[bkk]

aşağıdaki kod ile çoğaltma işlemini sağladım, ancak ikinci kitaptan hala veriyi çekemedim;

Sub SatirCokalt()
Dim satirSayisi As Integer
Dim i As Integer
Dim adet As Integer

' İlk satırı atla, başlıkları tutmak için
satirSayisi = Cells(Rows.Count, "F").End(xlUp).Row

For i = satirSayisi To 2 Step -1
' F sütunundaki adet değerini al
adet = Cells(i, "g").Value

' Adet kadar satırı çoğalt
If adet > 1 Then
' Satırı adet kadar çoğalt
Rows(i + 1 & ":" & i + adet - 1).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
' İlgili satırın verilerini çoğalt
Rows(i).Copy
Rows(i + 1 & ":" & i + adet - 1).PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False ' Kopyalama modunu kapat
End If
Next i
End Sub

 

[veyselemre]

PQ and ADO ....

Sub birlestir()
    Application.ScreenUpdating = False
    Dim strSQL$, rs As Object, r, dosya(1 To 2), sat, i, ii, dic As Object, adoCon As Object, ky$, w
    Set dic = CreateObject("Scripting.Dictionary")
    Set adoCon = CreateObject("AdoDB.Connection")
    With Sheets("Dosyalar")
        dosya(1) = .Range("A2").Value & "\" & .Range("B2").Value
        dosya(2) = .Range("A3").Value & "\" & .Range("B3").Value
    End With

    With adoCon
        strSQL = "SELECT [NO],FORMAT(TARİH,'dd.mm.yyyy'),[1],[2],[3],ADET,[5],[6],[7] FROM [Sayfa1$]"
        .Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=1';" & _
              "Data Source=" & dosya(1)
        Set rs = .Execute(strSQL)
    End With
    sat = 1
    With Sheets("ADO")
        .Cells.ClearContents
        .Range("A1:O1").Value = Array("NO", "TARİH", "1", "2", "3", "ADET", "5", "6", "7", "S.N", "AD", "SOYAD", "X", "Y", "TARİHİ")
        If Not rs.EOF Then
            Do While Not rs.EOF
                For i = 1 To rs("ADET")
                    sat = sat + 1
                    For ii = 0 To rs.Fields.Count - 1
                        .Cells(sat, ii + 1).Value = rs.Fields(ii)
                    Next ii
                    ky = .Cells(sat, 2).Value & .Cells(sat, 4).Value & .Cells(sat, 5).Value
                    If Not dic.exists(ky) Then
                        dic(ky) = Array(sat, sat)
                    Else
                        w = dic(ky)
                        w(1) = sat
                        dic(ky) = w
                    End If
                Next i
                rs.MoveNext
            Loop
        End If
        rs.Close
    End With
    adoCon.Close
    With adoCon
        strSQL = "SELECT [S#N],AD,SOYAD,X,Y,FORMAT(TARİHİ,'dd.mm.yyyy') FROM [Sayfa1$]"
        .Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=1';" & _
              "Data Source=" & dosya(2)
        Set rs = .Execute(strSQL)
    End With
    sat = 1
    With Sheets("ADO")
        If Not rs.EOF Then
            Do While Not rs.EOF
                ky = rs(5) & rs(3) & rs(4)
                If dic.exists(ky) Then
                    w = dic(ky)
                    sat = w(0)
                    For ii = 0 To rs.Fields.Count - 1
                        .Cells(sat, ii + 10).Value = rs.Fields(ii)
                    Next ii
                    w(0) = w(0) + 1
                    If w(0) > w(1) Then
                        dic.Remove (ky)
                    Else
                        dic(ky) = w
                    End If
                End If
                rs.MoveNext
            Loop
        End If
        rs.Close
        .Columns.AutoFit
    End With
    Application.ScreenUpdating = True
End Sub

 

[bkk]

Çok teşekkür ediyorum. Emeğiniz için ayrıca teşekkür ediyorum. Denedim sonuç aldım.