İki ayrı tabloyu tek tablo olarak birleştirme

[dost]

Herkese merhaba,

Ekteki resimde görüleceği üzere, 2 ayrı tablom var ve ben bu tabloları ayrı bir sayfada İstediğim sonuç kısmındaki gibi her tanımı kendi tanımı hizasında almak istiyorum.

Özellikle SQL ile yapmak istiyorum. Denedim ancak ROW_NUMBER() fonksiyonunu VBA desteklemediğinden sonuca ulaşamadım.

Yardımcı olacak arkadaşlara şimdiden teşekkür ederim.

 

[dost]

Merhaba,

Bulduğum çözüm:

Sub CreateRowNumber()
Dim oDict As Object
Dim conn As Object
Dim strSQL As String
Dim s1 As Worksheet
Dim myData1 As Variant, myData2 As Variant
Dim iCounter, Say, iRow As Integer

Set s1 = Sheets("Sheet2")
Set oDict = VBA.CreateObject("Scripting.Dictionary")
    
myData1 = s1.Range("A2:B" & s1.Cells(s1.Rows.Count, 1).End(3).Row).Value
myData2 = s1.Range("D2:E" & s1.Cells(s1.Rows.Count, 4).End(3).Row).Value

ReDim myList(1 To UBound(myData1, 1), 1 To UBound(myData1, 2) + 1)

For iRow = LBound(myData1, 1) To UBound(myData1, 1)
    If Not oDict.Exists(myData1(iRow, 1)) Then
        Say = Say + 1
        oDict.Add myData1(iRow, 1), Say
        iCounter = 1
    Else
        iCounter = iCounter + 1
    End If
    
    myList(iRow, 1) = iCounter
    myList(iRow, 2) = myData1(iRow, 1)
    myList(iRow, 3) = myData1(iRow, 2)
Next

Sheet4.Range("A2").Resize(UBound(myData1, 1), 3) = myList

oDict.RemoveAll
Erase myList

ReDim myList(1 To UBound(myData2, 1), 1 To UBound(myData2, 2) + 1)

Say = 1
For iRow = LBound(myData2, 1) To UBound(myData2, 1)
    If Not oDict.Exists(myData2(iRow, 1)) Then
        Say = Say + 1
        oDict.Add myData2(iRow, 1), Say
        iCounter = 1
    Else
        iCounter = iCounter + 1
    End If
    myList(iRow, 1) = iCounter
    myList(iRow, 2) = myData2(iRow, 1)
    myList(iRow, 3) = myData2(iRow, 2)
Next

Sheet4.Range("F2").Resize(UBound(myData2, 1), 3) = myList


Set conn = CreateObject("ADODB.Connection")

conn.Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=0';Data Source=" & ThisWorkbook.FullName

strSQL = "SELECT t1.*, t2.* FROM [Sheet4$A1:C] t1 " & _
             "LEFT JOIN [Sheet4$F1:H] t2 ON t1.[ID] = t2.[ID] AND t1.[Tanım] = t2.[Tanım] " & _
             "UNION " & _
             "SELECT t1.*, Null, Null, Null FROM [Sheet4$A1:C] t1 " & _
             "WHERE t1.[Tanım] NOT IN (SELECT [Tanım] FROM [Sheet4$F1:H])  " & _
             "UNION " & _
             "SELECT  Null, Null, Null, t1.* FROM [Sheet4$F1:H] t1 " & _
             "WHERE t1.[Tanım] NOT IN (SELECT [Tanım] FROM [Sheet4$A1:C]) " & _
             "ORDER BY  t1.[Tanım], t1.[ID], t1.[Tutar]"

Set RS = conn.Execute(strSQL)

Sheet4.Range("K1").Resize(1, 6) = Array("ID", "Tanım", "Tutar", "ID", "Tanım", "Tutar")
Sheet4.Range("K2").CopyFromRecordset RS

oDict.RemoveAll
Erase myList
Set s1 = Nothing:  Set oDict = Nothing:   Set conn = Nothing:   Set RS = Nothing

End Sub

 

[veyselemre]

Sub test()

    Dim i&, myArr1, myArr2, onc$, say%, ID$

    With Sheets("Sheet2")
        myArr1 = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
        myArr2 = .Range("D2:E" & .Cells(Rows.Count, 4).End(3).Row).Value
    End With

    With CreateObject("ADODB.Recordset")
        .Fields.Append "Tanım-1", 8, 100
        .Fields.Append "Tutar-1", 5
        .Fields.Append "Tanım-2", 8, 100
        .Fields.Append "Tutar-2", 5
        .Fields.Append "ID", 129, 10
        .Open
        For i = 1 To UBound(myArr1)
            If onc <> myArr1(i, 1) Then say = 0: onc = myArr1(i, 1)
            say = say + 1
            ID = myArr1(i, 1) & say
            .AddNew Array("ID", "Tanım-1", "Tutar-1"), Array(ID, myArr1(i, 1), myArr1(i, 2))
        Next i
        onc = ""
        For i = 1 To UBound(myArr2)
            If onc <> myArr2(i, 1) Then say = 0: onc = myArr2(i, 1)
            say = say + 1
            ID = myArr2(i, 1) & say
            .Filter = ("ID='" & ID & "'")
            If Not .EOF Then
                .Fields("Tanım-2") = myArr2(i, 1)
                .Fields("Tutar-2") = myArr2(i, 2)
            Else
                .AddNew Array("ID", "Tanım-2", "Tutar-2"), Array(ID, myArr2(i, 1), myArr2(i, 2))
            End If
            .Filter = ""
        Next i
        .Sort = "ID"
        Sheets("Sheet2").Range("G:K").ClearContents
        myArr1 = Application.Transpose(.GetRows(, , Array(0, 1, 2, 3)))
        Sheets("Sheet2").Range("G2").Resize(UBound(myArr1), UBound(myArr1, 2)).Value = myArr1
    End With
    
End Sub

Sub test2()

    Dim i&, ii&, iii%, tmp$, myArr1, myArr2, onc$, say%, tanim$, liste(), idx&, sira&

    With Sheets("Sheet2")
        myArr1 = .Range("A2:B" & .Cells(Rows.Count, 1).End(3).Row).Value
        myArr2 = .Range("D2:E" & .Cells(Rows.Count, 4).End(3).Row).Value
    End With

    ReDim liste(1 To UBound(myArr1) + UBound(myArr2), 1 To 5)

    With CreateObject("Scripting.Dictionary")

        For i = 1 To UBound(myArr1)
            If onc <> myArr1(i, 1) Then
                say = 1
            Else
                say = say + 1
            End If
            onc = myArr1(i, 1)
            tanim = myArr1(i, 1) & say
            idx = idx + 1
            .Item(tanim) = idx
            liste(idx, 5) = tanim
            liste(idx, 1) = myArr1(i, 1)
            liste(idx, 2) = myArr1(i, 2)
        Next i

        onc = ""
        For i = 1 To UBound(myArr2)
            If onc <> myArr2(i, 1) Then
                say = 1
            Else
                say = say + 1
            End If
            onc = myArr2(i, 1)
            tanim = myArr2(i, 1) & say
            If Not .exists(tanim) Then
                idx = idx + 1
                .Item(tanim) = idx
                liste(idx, 5) = tanim
            End If
           
            sira = .Item(tanim)
            liste(sira, 3) = myArr2(i, 1)
            liste(sira, 4) = myArr2(i, 2)
        Next i
       
    End With
   
    For i = 1 To idx - 1
        For ii = i + 1 To idx
            If liste(i, 5) > liste(ii, 5) Then
                For iii = 1 To 5
                    tmp = liste(i, iii)
                    liste(i, iii) = liste(ii, iii)
                    liste(ii, iii) = tmp
                Next iii
            End If
        Next ii
    Next i

    Sheets("Sheet2").Range("L:P").ClearContents
    Sheets("Sheet2").Range("L2").Resize(idx, 4).Value = liste

End Sub

 

[veyselemre]

Sub test3()
    Dim strSQL$, rs As Object, r
    Sheet4.Activate
    Range("A:N").ClearContents

    With Sheets("Sheet2")
        .Range("A1:B" & .Cells(.Rows.Count, 1).End(3).Row).Copy Range("B1")
        .Range("D1:E" & .Cells(.Rows.Count, 1).End(3).Row).Copy Range("G1")
    End With

    For Each r In Array(Range("B2").CurrentRegion, Range("G2").CurrentRegion)
        With r.Offset(1, -1).Resize(r.Rows.Count - 1, 1)
            .Formula = "=COUNTIF(R2C[1]:RC[1],RC[1])"
            .Value = .Value
        End With
    Next r
    Range("A1,F1").Value = "ID"

    strSQL = "SELECT FIRST(Tanım1), SUM(Tutar1), LAST(Tanım2), SUM(Tutar2) FROM " & _
             "(" & _
             "SELECT Tanım&ID AS yID, Tanım AS Tanım1, Tutar AS Tutar1, NULL AS Tanım2, NULL AS Tutar2 FROM " & _
             "[Sheet4$A1:C] WHERE NOT ISNULL(ID)" & _
             "UNION ALL " & _
             "SELECT Tanım&ID as yID, null AS Tanım1, null AS Tutar1, Tanım AS Tanım2, Tutar as Tutar2 FROM " & _
             "[Sheet4$F1:H] WHERE NOT ISNULL(ID)" & _
             ") GROUP BY yID "

    With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.Ace.Oledb.12.0;Extended Properties='Excel 12.0;HDR=YES;IMEX=0';Data Source=" & ThisWorkbook.FullName
        Set rs = .Execute(strSQL)
        Range("K1").Resize(1, 4) = Array("Tanım", "Tutar", "Tanım", "Tutar")
        Range("K2").CopyFromRecordset rs
    End With
End Sub

 

[dost]

@veyselemre,

İlk önce ilgin için ve ayrıca yapmış olduğun üç tane güzel çözüm için teşekkür ederim.