Matching column headings (name) in destination workbook, then copying values from source workbook

Question

I have written the following code which should, match column headings in destination workbook, search for the same column heading in the source workbook (worksheet), fetch all the data under that particular column till the end of the row and copy it under the same column heading in the destination workbook (worksheet).

This task should be performed till all the columns in the destination workbook's worksheet gets filled.

Sub LPN()

Dim CurrentWS As Worksheet
Set CurrentWS = ActiveSheet

ActiveWorkbook.Sheets("controls").Select

'I have made a sheet in the main workbook(Rates EMEA CDS PT+FVA.v1.25 Apr 2016.i1.xlsm)
' known as **controls** , in this sheet I have specified  the path of the
' workbook(worksheet) that has to be opened and from where the data has to be copied.
'The name of the cell where the path has been mentioned I named it as GPL 

Set master = ActiveWorkbook
GPL = Range("GPL").Value

Workbooks.Open Filename:=GPL
Set GPLfile = ActiveWorkbook
'Open the particular workbook with specified worksheet having .xlsx extension

Dim SourceWS As Worksheet
Set SourceWS = ActiveWorkbook.Worksheets("PNL Attribution")

Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range

Workbooks("Rates EMEA CDS PT+FVA.v1.25 Apr 2016.i1.xlsm").Activate

Dim TargetWS As Worksheet
Set TargetWS = Worksheets("PNL Attribution")

Dim TargetHeader As Range

'The code will look for all the column headings in the source workbook
' match it with the headings in the target workbook(worksheet) which are not in order.
Set TargetHeader = TargetWS.Range("A10:ZZ10")

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

hi ! I am naïve on vba (not able to understand how it will help my problem the link which u shared )could you let me know what are the changes that I can make in the above mentioned code .. so that it works fine ? — GOPAL AGARWAL
begin copying and pasting the code to a brand new Module so you can test it without affecting your current code. then go on following the comments in the code itself and adapt it to your specific needs (workbooks and worksheet names, TargetHeader range). finally ... watch what happens and if it isn't satisfactory step through the code placing breakpoints in it where you may find appropriate and press F8 to see what's happening (query variable values in the Immediate Window"). Trial & error is what we all have been through and learned the most from. — user3598756
performed step wise analysis.Hi the code is not recognizing any target header columns in the main source file..it is returning blank .. can u help me with this ? — GOPAL AGARWAL

Михаил Попов Михаил Попов · Accepted Answer · 2019-08-14T22:56:31

Can you adapt it to your task?

Sub Cols_Value_Add_test()
    Set shSour = Worksheets("1")
    Set shDest = Worksheets("2")

    Dim rngSour As Range, rngDest As Range

    Set rngSour = shSour.Cells(3, 2)
    Set rngDest = shDest.Cells(3, 3)

    Dest_Row = rngDest.Row + rngDest.CurrentRegion.Rows.Count

    Cols_Value_Add rngSour, rngDest

End Sub

Sub Cols_Value_Add(rngSour As Range, _
                   rngDest As Range)
    Dim rngDest_Col As Long, rngDest_Col_Max As Long
    Dim shSour_Col As Long

    rngDest_Col_Max = rngDest.CurrentRegion.Columns.Count

    For rngDest_Col = 1 To rngDest_Col_Max
        shSour_Col = shSour_Col_Find(rngDest, rngDest_Col)
        If shSour_Col > 0 Then _
           CopyPaste rngSour, shSour_Col, rngDest, rngDest_Col

    Next
End Sub

Sub CopyPaste(rngSour As Range, _
              shSour_Col As Long, _
              rngDest As Range, _
              rngDest_Col As Long)

    Dim Sour_Row_Max As Long

    Sour_Row_Max = rngSour.CurrentRegion.Row + rngSour.CurrentRegion.Rows.Count - 1

    With shSour
        Set rngSour = .Range(.Cells(rngSour.Row, shSour_Col), _
                             .Cells(Sour_Row_Max, shSour_Col))
    End With

    rngSour.Copy

    rngDest_Col = rngDest.Row + rngDest_Col - 1

    shDest.Cells(Dest_Row, rngDest_Col).PasteSpecial _
            Paste:=xlPasteValues
End Sub

Function shSour_Col_Find(rngDest As Range, _
                         rngDest_Col As Long) _
                         As Long
    Dim sHeader As String, rng As Range

    sHeader = rngDest.Cells(1, rngDest_Col).Value

    Set rng = shSour.Cells.Find(sHeader, , , xlWhole)

    If Not rng Is Nothing Then _
       shSour_Col_Find = rng.Column

End Function

Matching column headings (name) in destination workbook, then copying values from source workbook

1 Answers