excel vba -基于列标题将数据从一个工作簿复制到另一个工作簿

qco9c6ql  于 2022-12-20  发布在  其他
关注(0)|答案(1)|浏览(282)

我正在尝试编写一个宏,该宏从一个工作簿读取列标题,在另一个工作簿中查找匹配的列标题,然后粘贴这些值。列标题分别位于源工作簿的第1行和目标工作簿的第5行。最后,我还希望在两个工作簿的多个选项卡之间循环,并执行相同的操作,但要循序渐进。

Sub EquipmentTransfer()

Dim sourceWB As Workbook, targetWB As Workbook
Dim sourceWS As Worksheet, targetWS As Worksheet
Dim sourceColumn As Range, targetColumn As Range

' Set sourceWB and targetWB to the workbooks you want to copy from and paste to
Set sourceWB = Workbooks("Memorial Hospital of South Bend Equipment List v0.2.xlsx")
Set targetWB = Workbooks("Memorial Hospital Energy Model v0.1.xlsm")

' Set sourceWS and targetWS to the worksheets you want to copy from and paste to
Set sourceWS = sourceWB.Sheets("Chillers")
Set targetWS = targetWB.Sheets("16 - Electric Chillers")

' Loop through each column in the source worksheet
For Each sourceColumn In sourceWS.Columns

    ' Check if the column header (in cell A1) exists in row 5 of the target worksheet
    On Error Resume Next
    If Not IsError(Application.Match(sourceColumn.Cells(1, 1).Value, targetWS.Rows(5), 0)) Then
        On Error GoTo 0

        ' If it exists, set targetColumn to the matching column in the target worksheet
        Set targetColumn = targetWS.Columns(Application.Match(sourceColumn.Cells(1, 1).Value, targetWS.Rows(5), 0))

        ' Copy the data from the source column, skipping the header row, and paste it into the target column, also skipping the first 4 rows
        sourceColumn.Offset(1, 0).Resize(sourceColumn.Rows.Count - 1, 1).Copy
        targetColumn.Offset(5, 0).PasteSpecial xlPasteValues
    End If

Next sourceColumn

End Sub

当前宏在第27行抛出了一个对象定义的错误,我还没能找出原因。
我已经删除了第27行的调整大小部分,但它抛出了相同的错误

moiiocjp

moiiocjp1#

尝试这样的东西-我已经抽出复制部分到一个单独的子,所以它更可重用。

Sub EquipmentTransfer()
    Dim sourceWB As Workbook, targetWB As Workbook
    
    Set sourceWB = Workbooks("Memorial Hospital of South Bend Equipment List v0.2.xlsx")
    Set targetWB = Workbooks("Memorial Hospital Energy Model v0.1.xlsm")
    
    CopyDataByHeader sourceWB.Sheets("Chillers").Rows(1), _
                     targetWB.Sheets("16 - Electric Chillers").Rows(5)
End Sub

'Copy data between two sheets, matching on headers in `sourceHeaderRow`
' and `targetHeaderRow`
Sub CopyDataByHeader(sourceHeaderRow As Range, targetHeaderRow As Range)
    Dim c As Range, hdr, m, rngCopy, wsSrc As Worksheet, wsTarg As Worksheet
    
    Set wsSrc = sourceHeaderRow.Worksheet
    Set wsTarg = targetHeaderRow.Worksheet
    
    For Each c In wsSrc.Range(sourceHeaderRow.Cells(1), _
                              sourceHeaderRow.Cells(wsSrc.Columns.Count).End(xlToLeft)).Cells
        hdr = c.Value
        If Len(hdr) > 0 Then 'have a header to look for?
            m = Application.Match(hdr, targetHeaderRow, 0) 'try to match header
            If Not IsError(m) Then                         'got a match?
                With wsSrc.Range(c.Offset(1), wsSrc.Cells(wsSrc.Rows.Count, c.Column).End(xlUp))
                    'copy values directly (used range only)
                    targetHeaderRow.Cells(m).Offset(1).Resize(.Rows.Count, .Columns.Count).Value = .Value
                End With
            End If     'matched the header
        End If         'have a header
    Next c
End Sub

相关问题