Based on Column Header find and copy data from one sheet to another

**Sachy** · 07-04-2013, 05:05 AM

Hello, I am looking for some easiest way how to do the following: 1) Find Column1 Header on sheet1, 2) Select all data from that column (Without Header to last used cell), 3) Copy this selection, 4) Find Column2 Header on sheet2, 5) Paste data below it

I have put together code that can do it but it seems very long to me and I now there is definitely a better way how to do that , so I will be thankful for any advice how to make it simpler, because then I can use it for more columns without having 1km of code

Option Explicit

Private Sub Search_Copy()
    
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim lastRow As Range
    Dim FindString As String
    Dim Rng As Range
    Dim ColumnB As Range
    Dim t As Variant
    
    Application.ScreenUpdating = False
    t = Timer

    'Define name of worksheets
    Set ws1 = ThisWorkbook.Worksheets("Sheet1")
    Set ws2 = ThisWorkbook.Worksheets("Sheet2")
    
    'First string(Header of Column) to find on ws1
    FindString = "Inventory date (YYYY-MM-DD)"

    If Trim(FindString) <> "" Then
        Set Rng = ws1.Cells.Find(What:=FindString, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

    If Rng = FindString Then
        Application.Goto Rng.Offset(1, 0), True
            
    'Get the last used row in column
        Set lastRow = Cells.Find(What:="", After:=[ActiveCell], SearchOrder:=xlByColumns, SearchDirection:=xlDown)
    
        Application.Goto Range(ActiveCell, lastRow.Offset(-1, 0))
    
    'Copy data from Rng to lastRow
    
        Selection.Copy
        
    Else
        MsgBox "Nothing found"
        
    End If
    End If
       
    'Find second Header on ws2
    
    ws2.Activate

    If Cells.Find("W2W Date", After:=ActiveCell, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
     xlNext, MatchCase:=True).Activate Then
    
    ActiveCell.Offset(2, 0).PasteSpecial
    
    Application.CutCopyMode = False
       
    Else
    
    Application.CutCopyMode = False
    MsgBox "Nothing found"
    
    End If
    
    Application.ScreenUpdating = True
    MsgBox "Time: " & Format(Timer - t, "00.00") & " seconds."

End Sub

**JBeaucaire** · 07-04-2013, 06:00 AM

Try this:

Option Explicit

Private Sub Search_Copy()
Dim ws1 As Worksheet, ws2 As Worksheet
Dim HeaderCells As Range, Hdr As Range, hdrFIND As Range

Application.ScreenUpdating = False                          'speed things up
Set ws1 = ThisWorkbook.Worksheets("Sheet1")                 'Define name of worksheets
Set ws2 = ThisWorkbook.Worksheets("Sheet2")

With ws1
    Set HeaderCells = .Rows(1).SpecialCells(xlConstants)    'a collection of the headers on ws1

    On Error Resume Next                                    'skip columns where header isn't found on ws2
    For Each Hdr In HeaderCells                             'process one header cell at a time
        Set hdrFIND = ws2.Rows(1).Find(Hdr.Text, LookIn:=xlValues, LookAt:=xlWhole)     'try to find match on ws2
        If Not hdrFIND Is Nothing Then                      'if found, copy to that column on ws2
            .Range(Hdr.Offset(1), .Cells(.Rows.Count, Hdr.Column)).Copy ws2.Cells(Rows.Count, hdrFIND.Column).End(xlUp).Offset(1)
        End If
    Next Hdr
End With

Application.ScreenUpdating = True                           'back to normal
End Sub

**Sachy** · 07-04-2013, 09:44 AM

Thanks for your reply, it was not exactly what I needed (while Headers aren't same on both sheets), but you point me in right way and with little utilizing it makes exactly what I want. And also the code looks better to me as the previous I have, thanks to you JBeaucaire - good job!