VBA to match headers and copy data from below

[billionaire2003]

Hi everyone,

I am looking for some VBA code to help me with the following problem, it would be great if anyone could help.

I have two excel sheets, both with identical headers except they are in a different order. Sheet1 has data, Sheet2 is blank except for the headers.

In sheet2 I would like to find the column in sheet1 that has the corresponding header, and copy all the data in the column and paste into correct column on sheet2. I would like to do this for all columns in sheet2. For example, the column with header name 'Fruit Type' in sheet2. I would like to find the column in sheet1 with the header 'Fruit Type', and copy all the data in that column into the 'Fruit Type' column in sheet2.


Any help welcomed.

Thanks

 

[mumps]

Glad it all worked out.

 

[ChanL]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column
    For Each header In desWS.Range(desWS.Cells(1, 1), desWS.Cells(1, lCol))
        Set foundHeader = srcWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(2, header.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

Hi there. Thanks for this amazing code. It helps me a lot in my excel reporting task. But if possible, would you share how to enable the copied data to be paste special (keep column width). Because when I run this code with my data, sometimes the column width runs, and make me faces problem when doing my next step.

I have try to declare a new variable - rangedes as range, then I set rangedes = desWs.cells(2,header.column)
then after that I change the copy paste code into this :
srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy
rangedes.pastespecial xlPastecolumnwidth

but I keep run into error and I have no idea how to solve it.....

Looking forward for your guidance. Thanks

 

[mumps]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column
    For Each header In desWS.Range(desWS.Cells(1, 1), desWS.Cells(1, lCol))
        Set foundHeader = srcWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy
            With desWS.Cells(2, header.Column)
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteColumnWidths
            End With
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

 

[jasoncheeseman]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column
    For Each header In desWS.Range(desWS.Cells(1, 1), desWS.Cells(1, lCol))
        Set foundHeader = srcWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(2, header.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

Hi @mumps, I know this is an old post, but I wonder if you could help me. The code is awesome but I've got an issue with the headers. On my "Sheet 1", the headers are on Row 3, on my "Sheet 2" the headers are on Row 5. This will change with different sheets. Can I put in a variable at the start of the code which sets these - like SourceSheetHeaderRow=3 and FinalSheetHeaderRow=5 and then include those variables in your code somehow?

 

[mumps]

See if this works for you.

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet
    Dim SourceSheetHeaderRow As Long, FinalSheetHeaderRow As Long
    SourceSheetHeaderRow = InputBox("Enter the source sheet header row number.")
    FinalSheetHeaderRow = InputBox("Enter the final sheet header row number.")
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column
    For Each header In desWS.Range(desWS.Cells(FinalSheetHeaderRow, 1), desWS.Cells(FinalSheetHeaderRow, lCol))
        Set foundHeader = srcWS.Rows(SourceSheetHeaderRow).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(2, header.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

 

[mitchec]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As Worksheet, desWS As Worksheet
    Set srcWS = Sheets("Sheet1")
    Set desWS = Sheets("Sheet2")
    LastRow = srcWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = desWS.Cells(1, Columns.Count).End(xlToLeft).Column
    For Each header In desWS.Range(desWS.Cells(1, 1), desWS.Cells(1, lCol))
        Set foundHeader = srcWS.Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            srcWS.Range(srcWS.Cells(2, foundHeader.Column), srcWS.Cells(LastRow, foundHeader.Column)).Copy desWS.Cells(2, header.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

Hello, Real newbie to vba and this forum, I know this is a fairly old post now, but this code is exactly what i am looking for, with a couple of tweeks (if possible). I have multiple sheets in a workbook and would like to be able to do the following within this code:
Select a different sheet either by means of an input box (rather than change the sheet name and add multiple mastersheets (1,2,3 etc)
or add more then one sheet to the code to add the contents of each sheet onto the mastersheet at the next available blank row.

At the moment i have to modify the sheet names to the next sheet in the workbook and destination sheet to mastersheet1, mastersheet2 etc and then copy all the mastersheets to another main mastersheet
Not sure if this should be a new thread or if its acceptable to post this here.
Thanks in advance for your help
CM

 

[mumps]

Are you saying that you want to have the option of choosing a particular source sheet and destination sheet each time you run the macro?

 

[mitchec]

Are you saying that you want to have the option of choosing a particular source sheet and destination sheet each time you run the macro?

Hi, yes if thats possible currently i modify the code for each sheet and have to create further master sheets as they overwrite the main master sheet. I then copy each master sheet to the main sheet. Does this make sense?

 

[mumps]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As String, desWS As String
    srcWS = InputBox("Enter the name of the source sheet.")
    If srcWS = "" Then Exit Sub
    desWS = InputBox("Enter the name of the destination sheet.")
    If desWS = "" Then Exit Sub
    LastRow = Sheets(srcWS).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = Sheets(desWS).Cells(1, Columns.Count).End(xlToLeft).Column
    For Each header In Sheets(desWS).Range(Sheets(desWS).Cells(1, 1), Sheets(desWS).Cells(1, lCol))
        Set foundHeader = Sheets(srcWS).Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            Sheets(srcWS).Range(Sheets(srcWS).Cells(2, foundHeader.Column), Sheets(srcWS).Cells(LastRow, foundHeader.Column)).Copy Sheets(desWS).Cells(2, header.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

Make sure that the source and destination sheets exist and avoid typo's when entering the sheet names.

 

[mitchec]

Try:

Sub CopyCols()
    Application.ScreenUpdating = False
    Dim LastRow As Long, header As Range, foundHeader As Range, lCol As Long, srcWS As String, desWS As String
    srcWS = InputBox("Enter the name of the source sheet.")
    If srcWS = "" Then Exit Sub
    desWS = InputBox("Enter the name of the destination sheet.")
    If desWS = "" Then Exit Sub
    LastRow = Sheets(srcWS).Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    lCol = Sheets(desWS).Cells(1, Columns.Count).End(xlToLeft).Column
    For Each header In Sheets(desWS).Range(Sheets(desWS).Cells(1, 1), Sheets(desWS).Cells(1, lCol))
        Set foundHeader = Sheets(srcWS).Rows(1).Find(header, LookIn:=xlValues, lookat:=xlWhole)
        If Not foundHeader Is Nothing Then
            Sheets(srcWS).Range(Sheets(srcWS).Cells(2, foundHeader.Column), Sheets(srcWS).Cells(LastRow, foundHeader.Column)).Copy Sheets(desWS).Cells(2, header.Column)
        End If
    Next header
    Application.ScreenUpdating = True
End Sub

Make sure that the source and destination sheets exist and avoid typo's when entering the sheet names.

This is absolutely brilliant and works like a charm. Thank you!