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
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
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
 
Upvote 0
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?
 
Upvote 0
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
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,253
Members
448,556
Latest member
peterhess2002

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top