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

tropics123

Board Regular
Joined
May 11, 2016
Messages
85
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
 

Some videos you may like

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Try this

Code:
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

Board Regular
Joined
May 11, 2016
Messages
85
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

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
I modified the code to search in row 4 on the "Headers" sheet

Code:
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

Board Regular
Joined
May 11, 2016
Messages
85

ADVERTISEMENT

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

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
 

tropics123

Board Regular
Joined
May 11, 2016
Messages
85

ADVERTISEMENT

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

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
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

Code:
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
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
12,593
Office Version
  1. 2007
Platform
  1. Windows
Again with pleasure. Thanks for the feedback
 

Watch MrExcel Video

Forum statistics

Threads
1,114,476
Messages
5,548,259
Members
410,825
Latest member
Dave12
Top