Macro to copy and paste based on column headings

Question

I'm very new to writing Macros in Excel, and have done a bit of looking around to try and solve my problem, but I haven't found a solution yet that works.

I'm trying to write a Macro to do the following:

I'm trying to copy data from Sheet 1, Workbook 1 based on column headings (so for example, I want to copy all the data under the column name "Sort"). The number of rows of data in this row may increase/decrease. I then want to paste this data into Sheet 2, Workbook 2 under the column name "Name". Columns may be added/removed from both workbooks, which is why I want to write the macro to copy based on the column name rather than a column number.

I have been using the below code, which I've tried putting together based on similar but slightly different requests I've found online, but when I run the macro, nothing much happens - I've written the Macro in Workbook 2 and it just opens Workbook 1.

If anyone can see something wrong with my code or suggest an alternative, I'd be extremely grateful for any help. Thanks!!!

Sub CopyProjectName()
    Dim CurrentWS As Worksheet
    Set CurrentWS = ActiveSheet
    Dim SourceWS As Worksheet
    Set SourceWS = Workbooks("Workbook1.xlsx").Worksheets("Sheet1")
    Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
    Dim SourceCell As Range, sRange As Range, Rng As Range
    Dim TargetWS As Worksheet
    Set TargetWS = Workbooks("Workbook2.xlsm").Worksheets("Sheet2")
    Dim TargetHeader As Range
    Set TargetHeader = TargetWS.Range("A1:AX1")
    Dim RealLastRow As Long
    Dim SourceCol As Integer

    Range("B2").Select
    SourceWS.Activate
    LastCol = Sheets("Sheet1").Cells(1, Columns.Count).End(xlToLeft).Column
    Set sRange = Sheets("Sheet1").Range("A1", Cells(1, LastCol))
    With sRange
        Set Rng = .Find(What:="Sort", _
                        After:=.Cells(1), _
                        LookIn:=xlValues, _
                        LookAt:=xlWhole, _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious, _
                        MatchCase:=False)
        If Not Rng Is Nothing Then
            LastRow = Sheets("Sheet1").Cells(Rows.Count, Rng.Column).End(xlUp).Row
            Sheets("Sheet1").Range(Rng, Cells(LastRow, Rng.Column)).Copy
            TargetWS.Activate
            Sheets("Sheet2").Range("B1").Paste
        End If
    End With
End Sub

I have "Sort" as one of my headings in Sheet 1 - it is currently in A1, but might not always be. I got most of the first part (the copy part) from looking at other codes, but the last bit (the paste part) I'm really not sure on! — nw201827

paul bica paul bica · Accepted Answer · 2018-04-09T08:58:14

Workbook1.xlsx and Workbook2.xlsm have to be open for the code bellow

Option Explicit

Public Sub CopyProjectName()
    Dim sourceWS As Worksheet, targetWS As Worksheet
    Dim lastCol As Long, lastRow As Long, srcRow As Range
    Dim found1 As Range, found2 As Range

    Set sourceWS = Workbooks("Workbook1.xlsx").Worksheets("Sheet1") 'Needs to be open
    Set targetWS = Workbooks("Workbook2.xlsm").Worksheets("Sheet2") 'Needs to be open

    With sourceWS
        lastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        Set srcRow = .Range("A1", .Cells(1, lastCol))
        Set found1 = srcRow.Find(What:="Sort", LookAt:=xlWhole, MatchCase:=False)

        If Not found1 Is Nothing Then
            lastCol = targetWS.Cells(1, Columns.Count).End(xlToLeft).Column
            Set srcRow = targetWS.Range("A1", targetWS.Cells(1, lastCol))
            Set found2 = srcRow.Find(What:="Name", LookAt:=xlWhole, MatchCase:=False)

            If Not found2 Is Nothing Then
                lastRow = .Cells(Rows.Count, found1.Column).End(xlUp).Row
                .Range(.Cells(2, found1.Column), .Cells(lastRow, found1.Column)).Copy
                found2.Offset(1, 0).PasteSpecial xlPasteAll
            End If
        End If
    End With
End Sub

Macro to copy and paste based on column headings

1 Answers