I need help with this vba code - copy and paste same header columns

[squeakums]

The below code is supposed to copy and paste same header columns from one sheet to another. Now, there might be some headers it cannot find. I want this code to just skip those and move on. I found this code on mr.excel.com and was hoping you would be able to resolve that section for me or if you know the answer, if error move on.

Sub CopyDataBlocks()

'VARIABLE NAME                 'DEFINITION
Dim SourceSheet As Worksheet    'The data to be copied is here
Dim TargetSheet 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 SourceSheet = Sheets("Workforce Detail")
Set TargetSheet = Sheets("hr_data")


With TargetSheet
    Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:C1")
    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 SourceSheet
    Set MyDataHeaders = .Range("A1:DJ1")
    
'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

 

[offthelip]

try this slight modification:

Sub CopyDataBlocks()

'VARIABLE NAME                 'DEFINITION
Dim SourceSheet As Worksheet    'The data to be copied is here
Dim TargetSheet 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 SourceSheet = Sheets("Workforce Detail")
Set TargetSheet = Sheets("hr_data")


With TargetSheet
    Set ColHeaders = .Range(.Cells(1, 1), .Cells(1, .Columns.Count).End(xlToLeft)) 'Or just .Range("A1:C1")
    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 SourceSheet
    Set MyDataHeaders = .Range("A1:DJ1")
    
'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
        If Application.WorksheetFunction.CountIf(ColHeaders, c.Value) <> 0 Then  ' Added this line
    
            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
        End If                                                                    ' and this one
    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

 

[squeakums]

Thank you, that worked and worked great