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

arnoldjay

New Member
Joined
Dec 1, 2008
Messages
7
Hello.

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

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! :)
 

Excel Facts

Workdays for a market open Mon, Wed, Friday?
Yes! Use "0101011" for the weekend argument in NETWORKDAYS.INTL or WORKDAY.INTL. The 7 digits start on Monday. 1 means it is a weekend.
I think you can use Consolidate built-in function somehow though...
try
Code:
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
 
Upvote 0
Correction
Code:
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 -->
 
Upvote 0
I think you can use Consolidate built-in function somehow though...
try
Code:
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?
 
Upvote 0
OOps, get rid of last " in a bracket
should be
Code:
a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value
It's in the corrected code as well...
 
Upvote 0
Can you use the corrected code with the correction of
a = Sheets("sheet" & i).Range("a1").CurrentRegion.Resize(,4).Value
?
 
Upvote 0
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.
 
Upvote 0
Correction
Code:
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.
 
Upvote 0

Forum statistics

Threads
1,212,929
Messages
6,110,743
Members
448,295
Latest member
Uzair Tahir Khan

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top