Question

问题：我正在尝试将数据从一个工作簿复制到另一个工作簿。

假设我有一个工作簿（称为DATA），其中包含几个填充数据的工作表。每列数据都有一个唯一的标题（同一行上的所有标题）。

另一方面，我有另一个工作簿（称为REPORT），其中一个工作表只包含数据的标题（在一行中）。它们的顺序与DATA工作簿中的顺序不同。例如，我在REPORT工作表中有3个标题，可以在DATA工作簿的不同工作表中找到。

我需要遍历DATA工作簿中的所有工作表，并在找到相同的标题时将整个列复制粘贴到REPORT工作表。

此图片可能有助于理解。解释

我的第一次尝试：

Dim MyFile As String
Dim ws As Worksheet

''Workbook that contains one worksheet with all the headings ONLY NO DATA
Dim TargetWS As Worksheet
Set TargetWS = ActiveSheet
Dim TargetHeader As Range

''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")

''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Dim SourceWB As Workbook
Set SourceWB = Workbooks("Source.xlsx")
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1
Dim SourceCell As Range

''Stores the col of the found value and the last row of data in that col
Dim RealLastRow As Long
Dim SourceCol As Integer

''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
    ws.Activate
    For Each Cell In TargetHeader
        If Cell.Value <> "" Then
            Set SourceCell = Rows(SourceHeaderRow).Find _
                (Cell.Value, LookIn:=xlValues, LookAt:=xlWhole)

            If Not SourceCell Is Nothing Then
                SourceCol = SourceCell.Column
                RealLastRow = Columns(SourceCol).Find("*", LookIn:=xlValues, _
                SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

                If RealLastRow > SourceHeaderRow Then
                    Range(Cells(SourceHeaderRow + 1, SourceCol), Cells(RealLastRow, _
                    SourceCol)).Copy
                    TargetWS.Cells(2, Cell.Column).PasteSpecial xlPasteValues
                End If
            End If
        End If
    Next
Next

我收到应用程序定义错误或对象定义错误运行时1004.我的逻辑/语法有问题吗？

请帮助我在VBA中如此糟糕。

提前致谢！

Answer 1

您上次编辑的代码有效

但是您正在进行不必要的检查，我建议您循环浏览每个工作表标题并检查它是否存在于TargetHeader范围内，以便随后将其列复制到SourceWB

此外，您可能希望让代码更加健壮，并在尝试为其设置变量之前检查实际需要的工作簿/工作表是否存在

如下：

Option Explicit

Sub main()

Dim SourceWB As Workbook
Dim ws As Worksheet, TargetWS  As Worksheet
Dim TargetHeader As Range, cell As Range, SourceCell As Range
Dim SourceHeaderRow As Integer: SourceHeaderRow = 1

''Source workbook that contains multiple sheets with data and headings _
not in same order as target file
Set SourceWB = GetWb("Source.xlsx")
If SourceWB Is Nothing Then Exit Sub

''Workbook that contains one worksheet with all the headings ONLY NO DATA
'Set TargetWS = ActiveSheet
Set TargetWS = GetWs("REPORT") 'it will get the first worksheet (if any) in "REPORT" workbook (if open)
If TargetWS Is Nothing Then Exit Sub

''Location of Headers I want to search for in source file
Set TargetHeader = TargetWS.Range("A1:G1")

''Looping through all worksheets in source file, looking for the heading I want _
then copying that whole column to the target file I have
For Each ws In SourceWB.Sheets
    For Each cell In ws.Rows(SourceHeaderRow).SpecialCells(xlCellTypeConstants, xlTextValues)
        Set SourceCell = TargetHeader.Find(cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
        If Not SourceCell Is Nothing Then
            Range(cell.Offset(1), ws.Cells(ws.Rows.Count, cell.Column).End(xlUp)).Copy
            SourceCell.Offset(1).PasteSpecial xlPasteValues
        End If
    Next
Next
End Sub


Function GetWb(wbName As String) As Workbook
    On Error Resume Next
    Set GetWb = Workbooks(wbName)
    On Error GoTo 0
    If GetWb Is Nothing Then MsgBox "Sorry, the workbook '" & wbName & "' isn't open" & vbCrLf & vbCrLf & "Please open it and run the macro again"
End Function


Function GetWs(wbName As String, Optional wsName As Variant) As Worksheet
    Dim wb As Workbook
    Dim ws As Worksheet

    Set wb = GetWb(wbName)
    If wb Is Nothing Then Exit Function

    On Error Resume Next
    If IsMissing(wsName) Then
        Set GetWs = wb.Worksheets(1) ' if no ws name passed then get the first one
    Else
        Set GetWs = wb.Worksheets(wsName)
    End If
    On Error GoTo 0
    If GetWs Is Nothing Then MsgBox "Sorry, the worksheet '" & wsName & "0 isn't in '" & wb.Name & "'" & vbCrLf & vbCrLf & "Please open a valid workbook and run the macro again"
End Function

尝试将数据从具有多个工作表的外部工作簿复制到另一个工作簿时出错

1 个答案: