Question

我非常擅长在Excel中编写宏，并且已经做了一些调查以尝试解决我的问题，但我还没有找到可行的解决方案。

我尝试编写宏来执行以下操作：

我尝试根据列标题从工作簿1复制工作簿1中的数据（例如，我想复制列名称下的所有数据＆＃34;排序＆＃34;）。此行中的数据行数可能会增加/减少。然后，我想将此数据粘贴到工作簿2，工作簿2的列名称＆＃34; Name＆＃34;。可以从两个工作簿中添加/删除列，这就是为什么我要根据列名而不是列号来编写要复制的宏。

我一直在使用下面的代码，我尝试根据我在网上找到的相似但略有不同的请求进行整理，但是当我运行宏时，没有什么事情发生 - 我＆＃39;已经在工作簿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

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

1 个答案: