VBA - copy and paste data based on columns headers

Indominus

Board Regular
Joined
Jul 11, 2020
Messages
126
Office Version
  1. 2016
Platform
  1. Windows
Hello. I have this code already that I found on this site and edited it a little bit to my fit my needs. I have two different workbooks. They each have most of the same headers but the order of them can be changed at random times unfortunately.

So I need to copy and paste all the data from my origin workbook’s “Combined” sheet matching the column headers to “Sheet1” in the Audit.csv workbook. This code does this somewhat however, I need it to start pasting the data down bottom after the last row used (aka first empty row). I will always have data in “Sheet”1 as this is a master data sheet I am building. Currently it starts pasting from the top of the worksheet. Also for some reason it pastes over some of my data midway through. Here is a screenshot showing an example of what both worksheets look like and here is the code. Thank you to anyone willing to help.

VBA Code:
Sub CopyPasteBasedonHeaders()





Dim sh1 As Worksheet, sh2 As Worksheet, wb1 As Workbook, wb2 As Workbook, a() As Variant, b() As Variant

Dim i As Long, j As Long, lr As Long, lc As Long, lr2 As Long



Set wb1 = ThisWorkbook

Set wb2 = Workbooks.Open("C:\Users\" & Environ("username") & "\Documents\Audit.csv")



Set sh1 = wb2.Sheets("Combined") 'origin

Set sh2 = wb1.Sheets("Sheet1") 'destination



'last row on origin sheet



lr = sh1.Range("A" & Rows.Count).End(xlUp).Row



'last row on destination sheet

lr2 = sh2.Range("A" & Rows.Count).End(xlUp).Row + 1



'Store headers in the "a" variable of the origin sheet



lc = sh1.Cells(1, Columns.Count).End(xlToLeft).Column

a = WorksheetFunction.Transpose(sh1.Range("A1", sh1.Cells(1, lc)).Value)



'Store headers in the "b" variable of the destination sheet

lc = sh2.Cells(1, Columns.Count).End(xlToLeft).Column

b = WorksheetFunction.Transpose(sh2.Range("A1", sh2.Cells(1, lc)).Value)



For i = 1 To UBound(a, 1)

For j = 1 To UBound(b, 1)



'Compare header

If b(j, 1) = a(i, 1) Then



'copy the column



sh2.Cells(2, j).Resize(lr).Value = sh1.Cells(2, i).Resize(lr).Value

Exit For

End If



Next

Next

MsgBox "End"

End Sub
 

Attachments

  • 0E3EE6C8-7658-4C61-9A9E-1D8D56B4C1C4.png
    0E3EE6C8-7658-4C61-9A9E-1D8D56B4C1C4.png
    189.3 KB · Views: 23

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,310
Office Version
  1. 2007
Platform
  1. Windows
Try this:

VBA Code:
Sub CopyPasteBasedonHeaders()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim wb1 As Workbook, wb2 As Workbook
  Dim j As Long, lr1 As Long, lr2 As Long
  Dim f As Range
  Application.ScreenUpdating = False
 
  Set wb2 = Workbooks.Open("C:\Users\" & Environ("username") & "\Documents\Audit.csv")
  Set sh1 = wb1.Sheets(1)         'origen
  Set wb2 = ThisWorkbook
  Set sh2 = wb2.Sheets("Sheet1")  'destination
 
  'last row on origin sheet
  lr1 = sh1.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
  'last row on destination sheet
  lr2 = sh2.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
 
  'for each head in sh1 (origen)
  For j = 1 To sh1.Cells(1, Columns.Count).End(1).Column
    Set f = sh2.Rows(1).Find(sh1.Cells(1, j), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      sh2.Cells(lr2, f.Column).Resize(lr1).Value = sh1.Cells(2, j).Resize(lr1).Value
    End If
  Next
  wb1.Close False
  Application.ScreenUpdating = True
  MsgBox "End"
End Sub
 
Last edited:

Indominus

Board Regular
Joined
Jul 11, 2020
Messages
126
Office Version
  1. 2016
Platform
  1. Windows
Try this:

VBA Code:
Sub CopyPasteBasedonHeaders()
  Dim sh1 As Worksheet, sh2 As Worksheet
  Dim wb1 As Workbook, wb2 As Workbook
  Dim j As Long, lr1 As Long, lr2 As Long
  Dim f As Range
  Application.ScreenUpdating = False
 
  Set wb2 = Workbooks.Open("C:\Users\" & Environ("username") & "\Documents\Audit.csv")
  Set sh1 = wb1.Sheets(1)         'origen
  Set wb2 = ThisWorkbook
  Set sh2 = wb2.Sheets("Sheet1")  'destination
 
  'last row on origin sheet
  lr1 = sh1.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
  'last row on destination sheet
  lr2 = sh2.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
 
  'for each head in sh1 (origen)
  For j = 1 To sh1.Cells(1, Columns.Count).End(1).Column
    Set f = sh2.Rows(1).Find(sh1.Cells(1, j), , xlValues, xlWhole, , , False)
    If Not f Is Nothing Then
      sh2.Cells(lr2, f.Column).Resize(lr1).Value = sh1.Cells(2, j).Resize(lr1).Value
    End If
  Next
  wb1.Close False
  Application.ScreenUpdating = True
  MsgBox "End"
End Sub
Works perfectly. I had to change some of the objects around and had to to put in my Sheet name for the Origin workbook but I got there. Thank you so much! One more thing if possible please.

I also need this code to work inside just one workbook that can have a varying number of sheets. I first combine this workbook with a basic code I have and then I run this one that you helped with between two workbooks. The first one however, just combines all sheets into a master one using the headers from the first one but if headers do not match it gets all out of sync.

So how could this new CopyPasteBasedonHeaders code be edited to loop through all sheets in one workbook besides the first one to copy and paste all data from them into the first sheet in the workbook matching the headers from the first sheet?

The workbook this will need to be done with is the wb2 one. Also the first master sheet will always be titled “results-0” if that matters. Thank you in advance!
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,310
Office Version
  1. 2007
Platform
  1. Windows
Works perfectly
Im glad to help you, thanks for the feedback.

So how could this new CopyPasteBasedonHeaders code be edited to loop through all sheets in one workbook besides the first one to copy and paste all data from them into the first sheet in the workbook matching the headers from the first sheet?
It is somewhat confusing for me.
Do you want a new macro?
Or could you explain it in steps?
 

Indominus

Board Regular
Joined
Jul 11, 2020
Messages
126
Office Version
  1. 2016
Platform
  1. Windows

ADVERTISEMENT

Im glad to help you, thanks for the feedback.


It is somewhat confusing for me.
Do you want a new macro?
Or could you explain it in steps?
Sorry about that. Just need this one edited slightly that’s all for a function I need to do prior. I need to loop through all sheets in the wb2 workbook and copy all sheet data to the first sheet (“results-0”) matching the headers. All sheets will look just like in the picture. wb2 might or might not have multiple sheets. So the same function as the other macro except this one is only dealing with one workbook.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,310
Office Version
  1. 2007
Platform
  1. Windows
Just need this one edited slightly that’s all

For me it is a new macro. Now you can why:

VBA Code:
Sub through_all_sheets()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim f As Range
  Dim j As Long, lr1 As Long, lr As Long
  
  Set sh1 = Sheets("results-0")
  
  For Each sh In Sheets
    If sh.Name <> sh1.Name Then
      lr1 = sh1.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
      lr = sh.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
      For j = 1 To sh.Cells(1, Columns.Count).End(1).Column
        Set f = sh1.Rows(1).Find(sh.Cells(1, j), , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then
          sh1.Cells(lr1, f.Column).Resize(lr).Value = sh.Cells(2, j).Resize(lr).Value
        End If
      Next
    End If
  Next
End Sub
 
Solution

Indominus

Board Regular
Joined
Jul 11, 2020
Messages
126
Office Version
  1. 2016
Platform
  1. Windows
For me it is a new macro. Now you can why:

VBA Code:
Sub through_all_sheets()
  Dim sh1 As Worksheet, sh As Worksheet
  Dim f As Range
  Dim j As Long, lr1 As Long, lr As Long
 
  Set sh1 = Sheets("results-0")
 
  For Each sh In Sheets
    If sh.Name <> sh1.Name Then
      lr1 = sh1.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row + 1
      lr = sh.Cells.Find("*", , xlValues, , xlByRows, xlPrevious).Row
      For j = 1 To sh.Cells(1, Columns.Count).End(1).Column
        Set f = sh1.Rows(1).Find(sh.Cells(1, j), , xlValues, xlWhole, , , False)
        If Not f Is Nothing Then
          sh1.Cells(lr1, f.Column).Resize(lr).Value = sh.Cells(2, j).Resize(lr).Value
        End If
      Next
    End If
  Next
End Sub
Works absolutely perfect! Thank you so much Dante! I greatly appreciate your assistance. I strive to be as proficient with VBA one day as you.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
13,310
Office Version
  1. 2007
Platform
  1. Windows
I'm glad to help you. Thanks for the feedback.
Keep practicing, it's the only way.
 

Forum statistics

Threads
1,136,801
Messages
5,677,811
Members
419,722
Latest member
Rizzol

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
Top