VBA - copy and paste data based on columns headers

[Indominus]

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.

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

 

[DanteAmor]

Try this:

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

 

[Indominus]

Try this:

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]

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]

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]

Just need this one edited slightly that’s all

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

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

 

[Indominus]

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

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]

I'm glad to help you. Thanks for the feedback.
Keep practicing, it's the only way.

 

[SE123654]

@DanteAmor Is it possible for you to look at my question: VBA Copy/Paste from different workbooks
It is based on your code in this thread.