Refresh table based on column headers

[iparras78]

All,
hoping someone can help. I have a table that needs refresh from other source based on column headers. Basically:

• "source" sheet will contain new data. there is a number of headers we dont use
• "target" sheet will have the headers (and data) we want to update

looking for a way to:
1/ look into "source" sheet for columns that exist in "target"
2/ refresh those columns only

Note:

• number of columns is not the same in both files
• order may vary in "source" sheet, hence it would need to "look for" them one by one

really appreciate any guidance you can provide

regards

 

[iparras78]

I found this code which seems to work, but would require the headers to be the same in both sheets. Appreciate any guidance on how to overcome that:
Sub CopyDataBlocks()


'VARIABLE NAME 'DEFINITION
Dim refresh As Worksheet 'The data to be copied is here
Dim Tableau As Worksheet 'The data will be copied here
Dim ColHeaders As Range 'Column headers on Target 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




'Change the names to match your sheetnames:
Set refresh = Sheets("refresh")
Set Tableau = Sheets("Tableau")




With Tableau
Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:FN1")
Set Rng = .Cells(.Rows.Count, 1).End(xlUp).Offset(1) 'Shoots up from the bottom of the sheet untill it bumps into something and steps one down
End With




With refresh
Set MyDataHeaders = .Range("A1:FN1")


'Makes sure all the column names are the same:
'Each header in Source sheet must have a match on Target sheet (but not necessarily in the same order + there can be more columns in Target sheet)
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 'The code exits here if thereäs no match for the column header
End If
Next c


'There was a match for each colum name.
'Set the first datablock to be copied:
Set DataBlock = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp)) 'A2:A & the last cell with something on it on column A




'Resizes the target Rng to match the size of the datablock:
Set Rng = Rng.Resize(DataBlock.Rows.Count, 1)




'Copies the data one column at a time:
For Each c In MyDataHeaders
i = Application.WorksheetFunction.Match(c.Value, ColHeaders, 0) 'Finds the matching column name
Rng.Offset(, i - 1).Value = Intersect(DataBlock.EntireRow, c.EntireColumn).Value 'Writes the values
Next c




'Uncomment the following line if you want the macro to delete the copied values:
' Intersect(MyDataHeaders.EntireColumn, DataBlock.EntireRow).ClearContents




End With




End Sub