Loop through worksheets, paste data in another worksheet in columns with matching name - excel

Question

I want to merge tables from multiple Excel sheets with uncommon and common column names.
I can't get the loop to go to sheets in my workbook and paste in the combine worksheet.
For example I have the following tables:
Sheet1:
name surname color
Eva x
steven y black
Mark z white
Sheet2:
Surname color name code
L Green Pim 030
O yellow Xander 34
S Rihanna 567
My third sheet (the combine sheet) has all the possible column names of all sheets so it looks like:
name surname color code
The macro should read Sheet1 and Sheet2 then paste data in the combine sheet under the correct column name.
The combine sheet should looks like this, with the elements of Sheet2 under the elements of Sheet1:
name surname color code
Eva x
steven y black
Mark z white
Pim L Green 030
Xander O yellow 34
Rihanna S 567
I couldn't get the loop to read then paste data in the right column.
Sub CopyDataBlocks_test2()
'VARIABLE NAME 'DEFINITION
Dim SourceSheet As Worksheet 'The data to be copied is here
Dim CombineSheet As Worksheet 'The data will be copied here
Dim ColHeaders As Range 'Column headers on Combine sheet
Dim MyDataHeaders As Range 'Column headers on Source sheet
Dim DataBlock As Range 'A single column of data
Dim c As Range 'a single cell
Dim Rng As Range
'The data will be copied here (="Place holder" for the first data cell)
Dim i As Integer
'Dim WS_Count As Integer 'for all sheets in active workbook
'Dim j As Integer 'Worksheets count
'Change the names to match your sheetnames:
Set SourceSheet = Sheets(2)
Set CombineSheet = Sheets("Combine")
With CombineSheet
Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End (xlToLeft))
Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
End With
With SourceSheet
Set MyDataHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
For Each c In MyDataHeaders
If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
MsgBox "Can't find a matching header name for " & c.Value & _
vbNewLine & "Make sure the column names are the same and try again."
Exit Sub
End If
Next c
'A2:A & the last cell with something on it on column A
Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)
For Each c In MyDataHeaders
i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0)
'Writes the values
Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value
Next c
End With
End Sub

Answer 1

you just wrap your With SourceSheet - End With block code into a For each sourceSheet in Worksheets - Next loop checking not to process "Combine" sheet itself
it'd be cleaner to move that into a helper Sub like follows:
Option Explicit
Sub CopyDataBlocks_test2()
'VARIABLE NAME 'DEFINITION
Dim sourceSheet As Worksheet 'The data to be copied is here
Dim ColHeaders As Range 'Column headers on Combine sheet
With Worksheets("Combine") '<--| data will be copied here
Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
For Each sourceSheet In Worksheets '<--| loop through all worksheets
If sourceSheet.Name <> .Name Then ProcessSheet sourceSheet, ColHeaders, .Cells(.Rows.Count, 1).End(xlUp).Offset(1) '<--| process data if not "Combine" sheet
Next
End With
End Sub
Sub ProcessSheet(sht As Worksheet, ColHeaders As Range, rng As Range)
Dim MyDataHeaders As Range 'Column headers on Source sheet
Dim c As Range 'a single cell
Dim i As Integer
Dim DataBlock As Range 'A single column of data
With sht
Set MyDataHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft))
For Each c In MyDataHeaders
If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) = 0 Then
MsgBox "In worksheet " & .Name & " can't find a matching header name for " & c.Value & vbNewLine & "Make sure the column names are the same and try again."
Exit Sub
End If
Next c
Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'A2:A & the last cell with something on it on column A
For Each c In MyDataHeaders
i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0)
rng.Offset(, i - 1).Resize(DataBlock.Rows.Count, 1).Value = DataBlock.Columns(c.Column).Value 'Writes the values
Next c
End With
End Sub