Help please: Checking multiple column data across two worksheets and combining them into one

[arnoldjay]

Hello.

I am fairly new at VBA programming but i know that this can be done i just can't figure out how...

So, what i want to do is 1 have a workbook with 3 worksheets. Sheet1 contains the columns:

Reference No. Line Item No. Amount Date
1 3 500 12/01
2 4 900 01/01
Sheet2:

Reference No. Line Item No. Quantity PersonInCharge
1 3 10 Kim
5 6 60 Noel

For sheet 3, what i want to happen is that when i run the VBA macro, it searches through both worksheets (Sheet1 and Sheet2), finding rows that have matching Reference No. AND Line Item No. and combine all of the columns (and values) for that particular row into another row in Sheet 3. So for the above data set, the resulting data in Sheet 3 would be:

Reference No. Line Item No. Amount Date Quanity PersonInCharge
1 3 500 12/01 10 Kim

As this is the only entry in both sheet1 and sheet2 where there is a matching reference and line item no.

Any help would be appreciated.

Thanks!

 

[jindon]

I think you can use Consolidate built-in function somehow though...
try

Sub test()
Dim a, e, b(), n As Long, t As Long, r As Range
Dim dic1 As Object, dic2 As Object
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
Set dic2 = CreateObject("Scripting.Dictionary")
dic2.CompareMode = vbTextCompare
For i = 1 To 2
    For Each r In Sheets("sheet" & i).Range("a1:d1")
        If Not dic2.exists(r.Value) Then
            t = t + 1 : dic2.add r.value, t
        End If
    Next
Next
ReDim b(1 To Rows.Count, 1 To dic2.Count) : n = 1
For i = 1 To 2
a = Sheets("sheet" & i").Range("a1").CurrentRegion.Resize(,4).Value
For i = 2 To UBound(a,1)
    z = a(i, 1) & ";" & a(i, 2)
    If Not dic1.exists(z) Then
        n = n + 1 : dic1.add z, n
        For ii = 1 To UBound(a,2) : b(n, dic2(a(1, ii))) = a(i, ii) : Next
    End If
Next
With Sheets("sheet3").Range("a1")
    .CurrentRegion.ClearContents
    .Resize(,dic2.count).value = dic2.keys
    .Offset(1).Resize(n, dic2.count).Value = b
End With
Set dic1 = Nothing : Set dic2 = Nothing
End Sub

 

[jindon]

Correction

Sub test()
Dim a, e, b(), n As Long, t As Long, r As Range
Dim dic1 As Object, dic2 As Object, i As Long, ii As Long, iii As Long
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
Set dic2 = CreateObject("Scripting.Dictionary")
dic2.CompareMode = vbTextCompare
For i = 1 To 2
    For Each r In Sheets("sheet" & i).Range("a1:d1")
        If Not dic2.exists(r.Value) Then
            t = t + 1 : dic2.add r.value, t
        End If
    Next
Next
ReDim b(1 To Rows.Count, 1 To dic2.Count) : n = 1
For i = 1 To 2
    a = Sheets("sheet" & i").Range("a1").CurrentRegion.Resize(,4).Value
    For ii = 2 To UBound(a,1)
        z = a(ii, 1) & ";" & a(ii, 2)
        If Not dic1.exists(z) Then
            n = n + 1 : dic1.add z, n
            For iii = 1 To UBound(a,2) : b(n, dic2(a(1, iii))) = a(ii, iii) : Next
        End If
    Next
Next
With Sheets("sheet3").Range("a1")
    .CurrentRegion.ClearContents
    .Resize(,dic2.count).value = dic2.keys
    .Offset(1).Resize(n, dic2.count).Value = b
End With
Set dic1 = Nothing : Set dic2 = Nothing
End Sub
<!-- / message -->

 

[arnoldjay]

I think you can use Consolidate built-in function somehow though...
try

Sub test()
Dim a, e, b(), n As Long, t As Long, r As Range
Dim dic1 As Object, dic2 As Object
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
Set dic2 = CreateObject("Scripting.Dictionary")
dic2.CompareMode = vbTextCompare
For i = 1 To 2
    For Each r In Sheets("sheet" & i).Range("a1:d1")
        If Not dic2.exists(r.Value) Then
            t = t + 1 : dic2.add r.value, t
        End If
    Next
Next
ReDim b(1 To Rows.Count, 1 To dic2.Count) : n = 1
For i = 1 To 2
a = Sheets("sheet" & i").Range("a1").CurrentRegion.Resize(,4).Value
For i = 2 To UBound(a,1)
    z = a(i, 1) & ";" & a(i, 2)
    If Not dic1.exists(z) Then
        n = n + 1 : dic1.add z, n
        For ii = 1 To UBound(a,2) : b(n, dic2(a(1, ii))) = a(i, ii) : Next
    End If
Next
With Sheets("sheet3").Range("a1")
    .CurrentRegion.ClearContents
    .Resize(,dic2.count).value = dic2.keys
    .Offset(1).Resize(n, dic2.count).Value = b
End With
Set dic1 = Nothing : Set dic2 = Nothing
End Sub

******
Hello! thanks for the prompt reply. Although i have done a little bit of programming, i cannot find the cause of the syntax error in your code for the line:

a = Sheets("sheet" & i").Range("a1").CurrentRegion.Resize(,4).Value...

a little help?

 

[jindon]

OOps, get rid of last " in a bracket
should be

a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value

It's in the corrected code as well...

 

[arnoldjay]

OOps, get rid of last " in a bracket
should be

a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value

It's in the corrected code as well...

oh, right. didn't notice that. will test now. Thanks!

 

[arnoldjay]

oh, right. didn't notice that. will test now. Thanks!

After running again, it seems that the line

For i = 2 To UBound(a, 1)

puts out the error: a = For control variable already in use

please help...

 

[jindon]

Can you use the corrected code with the correction of
a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value
?

 

[arnoldjay]

Can you use the corrected code with the correction of
a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value
?

Edit on my last post:

For i = 2 To UBound(a, 1)

puts out the error: "For control variable already in use"


*** And yes, i have already removed the " after the i on the line
a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value and the error no longer appears there.

 

[jindon]

Correction

Sub test()
Dim a, e, b(), n As Long, t As Long, r As Range
Dim dic1 As Object, dic2 As Object, i As Long, ii As Long, iii As Long
Set dic1 = CreateObject("Scripting.Dictionary")
dic1.CompareMode = vbTextCompare
Set dic2 = CreateObject("Scripting.Dictionary")
dic2.CompareMode = vbTextCompare
For i = 1 To 2
    For Each r In Sheets("sheet" & i).Range("a1:d1")
        If Not dic2.exists(r.Value) Then
            t = t + 1 : dic2.add r.value, t
        End If
    Next
Next
ReDim b(1 To Rows.Count, 1 To dic2.Count) : n = 1
For i = 1 To 2
    a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value
    For ii = 2 To UBound(a,1)
        z = a(ii, 1) & ";" & a(ii, 2)
        If Not dic1.exists(z) Then
            n = n + 1 : dic1.add z, n
            For iii = 1 To UBound(a,2) : b(n, dic2(a(1, iii))) = a(ii, iii) : Next
        End If
    Next
Next
With Sheets("sheet3").Range("a1")
    .CurrentRegion.ClearContents
    .Resize(,dic2.count).value = dic2.keys
    .Offset(1).Resize(n, dic2.count).Value = b
End With
Set dic1 = Nothing : Set dic2 = Nothing
End Sub
<!-- / message -->

This one.