Macro to Copy Entitre column of Matching Column Header & Paste to Matching Column Header

[zach9208]

Hi There,

I need help building a macro that copies entire columns from one workbook over to another based on matching column names in row 1. These copied columns would then need pasted in another workbook based on the matching column names.

Another way of saying this is to use macros to do a H-Lookup and paste entire columns to another workbook.I have done this before from the source to a blank but now I need to match the source column name and pull those columns to the matching column name of the destination workbook.

For example: workbook 1 has a bunch of columns. I have three columns mixed in there called "TEST1", "TEST5", TEST17". I need to copy these three named columns over to Workbook 2 in the tab called existing and paste these in the columns sharing these three names. The column order can vary between the files hence why I am trying to copy/paste based on the matching column names that I specify in the macro.

I also need this to be a loop and copy data from multiple tabs to paste into the consolidated workbook. These tabs are called Source1, Source2, source3 and Source4.


Here is the code I had for a similar project that was just copy certain columns into a brand new workbook..

Sub CreateUserInitiatedLoadCSV()
Dim wbNew As Workbook, wbSrc As Workbook, Error As Range
Dim SaveToDirectory$, CurrentWorkbook$, KeepRunning As VbMsgBoxResult
Dim CurrentFormat&, nmary, sh1 As Worksheet, sh2 As Worksheet, i&, rng As Range

    Call FormatColumnstoText
    Set wbSrc = ThisWorkbook


    nmary = Array("TEST1", "TEST5", "TEST7")
    Set wbNew = Workbooks.Add


    Set sh2 = wbNew.Sheets(1)
    For i = LBound(nmary) To UBound(nmary)
        Set rng = sh1.Rows(4).Find(nmary(i), , xlValues).EntireColumn
        rng.Copy sh2.Cells(1, i + 1)
    Next
     
   
   ' Store current details for the workbook
    CurrentWorkbook = ThisWorkbook.FullName
    CurrentFormat = ThisWorkbook.FileFormat
    
    SaveToDirectory = "C:\Users\c755748\Desktop\" 
    wbNew.SaveAs Filename:=SaveToDirectory & "Counterparty_Ratings" & ".xlsx", FileFormat:=xlsx
    
    wbNew.Close savechanges:=False


    Application.DisplayAlerts = False
    ThisWorkbook.SaveAs Filename:=CurrentWorkbook, FileFormat:=CurrentFormat
    Application.DisplayAlerts = True
End Sub