根据列标题复制和粘贴的宏

Question

我对在 Excel 中编写宏还很陌生，并且做了一些环顾四周以尝试解决我的问题，但我还没有找到有效的解决方案。

我正在尝试编写一个宏来执行以下操作：

我正在尝试根据列标题从 Sheet 1，工作簿 1 中复制数据（例如，我想复制列名 "Sort" 下的所有数据）。这一行数据的行数可能increase/decrease。然后我想将此数据粘贴到列名 "Name" 下的 Sheet 2, Workbook 2 中。列可能是来自两个工作簿的 added/removed，这就是为什么我想编写宏以根据列名而不是列号进行复制。

我一直在使用下面的代码，我尝试根据我在网上找到的类似但略有不同的请求将这些代码放在一起，但是当我运行宏时，什么也没发生 - 我'在工作簿 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

根据列标题复制和粘贴的宏

Macro to copy and paste based on column headings

excel

vba

copy-paste