Macro to combine two sheets based on common ID number for 7 sheets

roroba

New Member
Joined
Apr 22, 2017
Messages
2
Hi all,

I found this excellent macro from a past post, lamentably this work fine for 2 sheets but lamentably
I could not modify to work with 7 sheets...

Please any advice I will gratefull
Regards

The macro is:

Sub TestGridUpdate()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim TestGridFound As Boolean
Dim r As Range

Set ws1 = ThisWorkbook.Worksheets("Sheet1")
Set ws2 = ThisWorkbook.Worksheets("Sheet2")

' Look for TestGrid worksheet
TestGridFound = False
For Each ws In Worksheets
If ws.Name = "TestGrid" Then TestGridFound = True
Next

'If TestGrid is found then use it else create it
If TestGridFound Then
Set ws3 = ThisWorkbook.Worksheets("TestGrid")
ws3.Cells.Clear
Else
Set ws3 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws3.Name = "TestGrid"
End If

' Copy ws1 to ws3 (TestGrid)
ws3.Range(ws1.UsedRange.Address).Value = ws1.UsedRange.Value

' Add ws2 details to ws3 (TestGrid)
For Each r In ws3.UsedRange.Rows
ID = r.Cells(, 1).Value
iRow = Application.Match(ID, ws2.UsedRange.Columns(1), 0)
ws2.Range("B" & iRow & ":U" & iRow).Copy ws3.Range("Q" & r.Row)
Next

End Sub
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Welcome to the Forum!

Your macro:

- copies the contents of "Sheet1" to "TestGrid"
- For each row in "TestGrid", finds the matching ID in Sheet2 and copies columns B:U from "Sheet2" into columns Q:AJ of "TestGrid".

What do you want to have happen with the other five worksheets?
 
Upvote 0
Possibly...
Code:
Sub TestGridUpdate()
    Dim WS As Worksheet
    Dim TG As Worksheet
    Dim r As Range
    Dim ID As Variant
    Dim iRow As Long
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    For Each WS In Worksheets
        If WS.Name = "TestGrid" Then WS.Delete
    Next
    Worksheets("Sheet1").Copy After:=Worksheets(Worksheets.Count)
    Set TG = Worksheets(Worksheets.Count)
    TG.Name = "TestGrid"
    
    For Each WS In Worksheets
        If WS.Name <> "TestGrid" And WS.Name <> "Sheet1" Then
            For Each r In TG.UsedRange.Rows
                ID = r.Cells(, 1).Value
                iRow = Application.Match(ID, WS.UsedRange.Columns(1), 0)
                WS.Range("B" & iRow & ":U" & iRow).Copy TG.Range("Q" & r.Row)
            Next
        End If
    Next
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
Hi all!

Thanks for your fast replay, lamentably I could not get good results with your advice (probably because my native language is spanish, so i could explain correctly) in my consolidate last table.

For this reason I modify succesfully the past macro, here I attach the last macro for 4 sheets (for spanish language:Hoja1...).

Regards anh thanks again

Sub TestGridUpdate()

Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim ws3 As Worksheet
Dim ws4 As Worksheet
Dim ws5 As Worksheet

Dim TestGridFound As Boolean
Dim r As Range

Set ws1 = ThisWorkbook.Worksheets("Hoja1")
Set ws2 = ThisWorkbook.Worksheets("Hoja2")
Set ws3 = ThisWorkbook.Worksheets("Hoja3")
Set ws4 = ThisWorkbook.Worksheets("Hoja4")

' Look for TestGrid worksheet
TestGridFound = False
For Each WS In Worksheets
If WS.Name = "TestGrid" Then TestGridFound = True
Next

'If TestGrid is found then use it else create it
If TestGridFound Then
Set ws5 = ThisWorkbook.Worksheets("TestGrid")
ws5.Cells.Clear
Else
Set ws5 = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws5.Name = "TestGrid"
End If

' Copy ws1 to ws3 (TestGrid)
ws5.Range(ws1.UsedRange.Address).Value = ws1.UsedRange.Value


' Add ws2 details to ws3 (TestGrid)
For Each r In ws5.UsedRange.Rows
ID = r.Cells(, 1).Value
iRow = Application.Match(ID, ws2.UsedRange.Columns(1), 0)
ws2.Range("B" & iRow & ":U" & iRow).Copy ws5.Range("C" & r.Row)

iRow = Application.Match(ID, ws3.UsedRange.Columns(1), 0)
ws3.Range("B" & iRow & ":U" & iRow).Copy ws5.Range("F" & r.Row)

iRow = Application.Match(ID, ws4.UsedRange.Columns(1), 0)
ws4.Range("B" & iRow & ":U" & iRow).Copy ws5.Range("H" & r.Row)

Next

End Sub
 
Upvote 0

Forum statistics

Threads
1,213,534
Messages
6,114,188
Members
448,554
Latest member
Gleisner2

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