CopyByHeader



Sub CopyByHeader()

    Dim CurrentWS As Worksheet
    Set CurrentWS = ActiveSheet

    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("Source.xlsx").Worksheets(1)
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
    Dim SourceCell As Range

    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Business Loader V7.1.xlsx").Worksheets(2)
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")

    Dim RealLastRow As Long
    Dim SourceCol As Integer

    SourceWS.Activate
    For Each Cell In TargetHeader
        If Cell.Value <> "" Then
            Set SourceCell = Rows(SourceHeaderRow).Find _
                (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
            If Not SourceCell Is Nothing Then
                SourceCol = SourceCell.Column
                RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
                If RealLastRow > SourceHeaderRow Then
                    Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                        SourceCol)).Copy
                    TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
                End If
            End If
        End If
    Next

    CurrentWS.Activate

End Sub

Comments

Popular posts from this blog

For time calculation in macro

number format

Filter Data