Question

我正在寻找一个宏来复制两个OPEN工作簿之间的数据匹配列标题。我有下面的代码来复制同一工作簿中的工作表之间的数据。但我需要如下所示在两个OPEN工作簿之间复制。

首先打开目标工作簿（在其中有一个宏按钮以复制数据）
第二个开源工作簿（以物理方式查看和验证数据）
第三步，转到目标工作簿，然后单击按钮进行复制。

任何人都可以帮助我。

Sub CopyMatchingHeaders()

Dim wbSource As Workbook
Dim SFileName As Variant

SFileName = Application.GetOpenFilename("Excel Files, *.xlsx, *.xls*,", MultiSelect:=False)

If TypeName(SFileName) = "String" Then
    Set wbSource = Workbooks.Open(SFileName)
Else
    MsgBox "No file selected."
    Exit Sub
End If


Dim header As Range, headers As Range
Set headers = ActiveWorkbook.Worksheets("Sheet1").Range("A1:AE1")

For Each header In headers
    If GetHeaderColumn(header.Value) > 0 Then
        Range(header.Offset(1, 0), header.End(xlDown)).Copy Destination:=ActiveWorkbook.Worksheets("Sheet2").Cells(2, GetHeaderColumn(header.Value))
    End If
Next

End Sub

Function GetHeaderColumn(header As String) As Integer
  Dim headers As Range
  Set headers = ActiveWorkbook.Worksheets("Sheet2").Range("A1:AE1")
  GetHeaderColumn = IIf(IsNumeric(Application.Match(header, headers, 0)), Application.Match(header, headers, 0), 0)
End Function

Answer 1

您可以尝试修改这些陈述：

Set headers = ActiveWorkbook.Worksheets("Sheet2").Range("A1:AE1")
'             ^^^^^^^^^^^^^^

和

ActiveWorkbook

将Workbooks("TheOtherWorkbookName")替换为：

"Sheet2"

目标工作表的名称也可能与{{1}}不同。

Excel宏用于复制两个OPEN WorkBook之间匹配列标题的数据

1 个答案: