Copy Columns from Origin Sheet Based on Header and Copy to a Different Sheet Under the Same Header

[tropics123]

Hi guys,

Just wondering if there's a more clean and condensed solution to this macro I'm working on. I'm trying to map data from a client's payroll file onto our template in order to upload it to our system for record keeping. I need to copy the data (all rows in the column directly below the header) from the client's payroll file, which consists of the headers: Last Name, Middle Initial, First Name , SSN, Hire Date; and paste the data directly below the respective headers in a different destination sheet. The headers on our template are not in the same order as the client's sheet, so the macro needs to find the same name on our template and copy below that header. Anyway, here's what I have so far but it means I have to repeat the same steps multiple times for each header name. Just wondering if there's a better condensed VBA code and I don't know how to add the code where it can find that specific header name in our template in order to paste the data.

There are two worksheets: 1) Client_Payroll (client's payroll file) 2) Headers (this is our template)

sub CopyandPaste()


Dim val
searchText = "Last Name"


Sheets("Client_Payroll").Select 'origin sheet
Range("A1").Select
Range(Selection, Selection.End(xlToRight)).Select
x = Selection.Columns.Count ' get number of columns


For i = 1 To x 'iterate through origin columns
val = Cells(1, i).Value
If val = searchText Then
Cells(1, i).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Sheets("Headers").Select 'destination sheet
Range("F4").Select
Range(Selection, Selection.End(xlToRight)).Select
y = Selection.Columns.Count 'get number of columns


For j = 1 To y 'iterate through destination columns


If Cells(1, j).Value = searchText Then
Cells(1, j).Select
ActiveSheet.Paste
Exit Sub
End If


Next j
End If
Next i


End Sub

 

[DanteAmor]

Try this

Sub Copy_Columns()
  Dim cols As Variant, sh1 As Worksheet, sh2 As Worksheet, i As Long, c As Long, f As Range
  Set sh1 = Sheets("Client_Payroll")
  Set sh2 = Sheets("Headers")
  cols = Array("[COLOR=#0000ff]Last Name", "Middle Initial", "First Name", "SSN", "Hire Date"[/COLOR])[COLOR=#008000] 'Put column titles here[/COLOR]
  For i = 0 To UBound(cols)
    Set f = sh1.Rows(1).Find(cols(i), , xlValues, xlWhole)
    If Not f Is Nothing Then
      c = f.Column
      Set f = sh2.Rows(1).Find(cols(i), , xlValues, xlWhole)
      If Not f Is Nothing Then
        sh1.Columns(c).Copy sh2.Columns(f.Column)
      End If
    End If
  Next
  MsgBox "End"
End Sub

 

[tropics123]

Hi Dante, I tried this macro and nothing is pasting to the the destination sheet "Headers". Is it possible to copy only the data below the header on the origin sheet "Client_Payroll" and paste values to the destination sheet "Headers", which starts on row 4?

 

[DanteAmor]

I modified the code to search in row 4 on the "Headers" sheet

Sub Copy_Columns()
  Dim cols As Variant, sh1 As Worksheet, sh2 As Worksheet
  Dim i As Long, c As Long, f As Range, lr As Long
  Set sh1 = Sheets("Client_Payroll")
  Set sh2 = Sheets("Headers")
  cols = Array("Last Name", "Middle Initial", "First Name", "SSN", "Hire Date")
  lr = sh1.UsedRange.Rows(sh1.UsedRange.Rows.Count).Row
  For i = 0 To UBound(cols)
    Set f = sh1.Rows(1).Find(cols(i), , xlValues, xlWhole)
    If Not f Is Nothing Then
      c = f.Column
[COLOR=#0000ff]      Set f = sh2.Rows(4).Find(cols(i), , xlValues, xlWhole)[/COLOR]
      If Not f Is Nothing Then
[COLOR=#0000ff]        sh1.Range(sh1.Cells(2, c), sh1.Cells(lr, c)).Copy sh2.Cells(5, f.Column)[/COLOR]
      End If
    End If
  Next
  MsgBox "End"
End Sub

 

[tropics123]

You're a genius...it worked like a charm! Thank you so much!

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.

 

[tropics123]

Hi Dante, I just thought of something and was wondering if it's a possibility. In case we have more headers in the future (current headers: last name, middle name, first name, SSN, hire date), is it possible to have the portion I highlighted in red below to refer to a worksheet called Sheet1 and the VBA to read those headers. I would add all those header names to column A in Sheet1. Meaning I would list all those header names and if I need to add another name such as "loan", I can add it to the list. I'm thinking this would be more user-friendly for someone who isn't familiar with VBA in the future.

Sub Mapping()
Dim cols As Variant, sh1 As Worksheet, sh2 As Worksheet
Dim i As Long, c As Long, f As Range, lr As Long
Set sh1 = Sheets("Client_Payroll_File")
Set sh2 = Sheets("Headers")
cols = Array("Last Name", "Middle Initial", "First Name", "SSN", "Hire Date")
lr = sh1.UsedRange.Rows(sh1.UsedRange.Rows.Count).Row
For i = 0 To UBound(cols)
Set f = sh1.Rows(1).Find(cols(i), , xlValues, xlWhole)
If Not f Is Nothing Then
c = f.Column
Set f = sh2.Rows(4).Find(cols(i), , xlValues, xlWhole)
If Not f Is Nothing Then
sh1.Range(sh1.Cells(2, c), sh1.Cells(lr, c)).Copy sh2.Cells(5, f.Column)
End If
End If
Next
MsgBox "End"
End Sub

 

[DanteAmor]

Hi Dante, I just thought of something and was wondering if it's a possibility. In case we have more headers in the future (current headers: last name, middle name, first name, SSN, hire date), is it possible to have the portion I highlighted in red below to refer to a worksheet called Sheet1 and the VBA to read those headers. I would add all those header names to column A in Sheet1. Meaning I would list all those header names and if I need to add another name such as "loan", I can add it to the list. I'm thinking this would be more user-friendly for someone who isn't familiar with VBA in the future.

Try this

Put the header names in A2 down on sheet1

Sub Copy_Columns()
  Dim cols As Variant, sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
  Dim i As Long, c As Long, f As Range, lr As Long
  Set sh1 = Sheets("Client_Payroll")
  Set sh2 = Sheets("Headers")
  Set sh3 = Sheets("Sheet1")
  '
[COLOR=#0000ff]  cols = sh3.Range("A2", sh3.Range("A" & Rows.Count).End(xlUp)).Value[/COLOR]
  lr = sh1.UsedRange.Rows(sh1.UsedRange.Rows.Count).Row
  For i = 1 To UBound(cols)
    Set f = sh1.Rows(1).Find([COLOR=#0000ff]cols(i, 1)[/COLOR], , xlValues, xlWhole)
    If Not f Is Nothing Then
      c = f.Column
      Set f = sh2.Rows(4).Find([COLOR=#0000ff]cols(i, 1)[/COLOR], , xlValues, xlWhole)
      If Not f Is Nothing Then
        sh1.Range(sh1.Cells(2, c), sh1.Cells(lr, c)).Copy sh2.Cells(5, f.Column)
      End If
    End If
  Next
  MsgBox "End"
End Sub

 

[tropics123]

This is amazing! It worked perfectly! Thank you so much!!!!

 

[DanteAmor]

Again with pleasure. Thanks for the feedback