Макрос для копирования и вставки на основе заголовков столбцов

Question

Я очень новичок в написании макросов в Excel и немного осмотрелся, чтобы попытаться решить мою проблему, но я пока не нашел решения, которое работает.

Я пытаюсь написать макрос, чтобы сделать следующее:

Я пытаюсь скопировать данные из листа 1, рабочей книги 1 на основе заголовков столбцов (например, я хочу скопировать все данные под именем столбца "Сортировка"). Количество строк данных в этой строке может увеличиваться / уменьшаться. Затем я хочу вставить эти данные в лист 2, рабочую книгу 2 под именем столбца "Имя". Столбцы могут быть добавлены / удалены из обеих книг, поэтому я хочу написать макрос для копирования на основе имени столбца, а не номера столбца.

Я использовал приведенный ниже код, который пытался собрать, основываясь на похожих, но немного отличающихся запросах, которые я нашел в Интернете, но когда я запускаю макрос, ничего особенного не происходит - я написал макрос в Workbook 2, и он просто открывается Рабочая тетрадь 1.

Если кто-то может увидеть что-то не так с моим кодом или предложить альтернативу, я был бы чрезвычайно признателен за любую помощь. Спасибо!!!

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  

Answer 1

Workbook1.xlsx а также Workbook2.xlsm должны быть открыты для кода ниже

---

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

Answer 2

      Sub CopyProjectName()
    ' Define source and target workbooks
    Dim sourceWorkbook As Workbook
    Dim targetWorkbook As Workbook

    ' Check if the source workbook is open, and open it if not
    On Error Resume Next
    Set sourceWorkbook = Workbooks("Workbook1.xlsx")
    On Error GoTo 0

    If sourceWorkbook Is Nothing Then
        ' Workbook is not open, so open it
        Set sourceWorkbook = Workbooks.Open("Path_to_Workbook1.xlsx")
    End If

    ' Check if the target workbook is open, and open it if not
    On Error Resume Next
    Set targetWorkbook = Workbooks("Workbook2.xlsm")
    On Error GoTo 0

    If targetWorkbook Is Nothing Then
        ' Workbook is not open, so open it
        Set targetWorkbook = Workbooks.Open("Path_to_Workbook2.xlsm")
    End If

    ' Define source and target worksheets
    Dim sourceWorksheet As Worksheet
    Dim targetWorksheet As Worksheet

    ' Set the source and target worksheets
    Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
    Set targetWorksheet = targetWorkbook.Worksheets("Sheet2")

    ' Define the column name to copy from source to target
    Dim columnName As String
    columnName = "Sort"

    ' Find the column with the specified column name in the source worksheet
    Dim sourceColumn As Range
    On Error Resume Next
    Set sourceColumn = sourceWorksheet.Rows(1).Find(What:=columnName, LookIn:=xlValues, LookAt:=xlWhole)
    On Error GoTo 0

    If Not sourceColumn Is Nothing Then
        ' Get the last row with data in the source column
        Dim lastRow As Long
        lastRow = sourceWorksheet.Cells(sourceWorksheet.Rows.Count, sourceColumn.Column).End(xlUp).Row

        ' Copy the data from the source column
        sourceWorksheet.Range(sourceColumn, sourceWorksheet.Cells(lastRow, sourceColumn.Column)).Copy

        ' Find the corresponding column in the target worksheet
        Dim targetColumn As Range
        On Error Resume Next
        Set targetColumn = targetWorksheet.Rows(1).Find(What:="Name", LookIn:=xlValues, LookAt:=xlWhole)
        On Error GoTo 0

        If Not targetColumn Is Nothing Then
            ' Paste the data into the target column
            targetWorksheet.Cells(1, targetColumn.Column).PasteSpecial xlPasteValues
        End If

        Application.CutCopyMode = False ' Clear the clipboard
    End If

    ' Close the workbooks (if they were opened by this macro)
    If sourceWorkbook.Name = "Workbook1.xlsx" Then
        sourceWorkbook.Close SaveChanges:=False
    End If

    If targetWorkbook.Name = "Workbook2.xlsm" Then
        targetWorkbook.Close SaveChanges:=False
    End If
End Sub