Question

我正在编写一个excel VBA脚本来遍历一组4张表，在一列数据的顶部找到一个字符串，遍历该列中的所有数据，并在摘要选项卡中打印标题和数据。

我是VBA的新手，即使经过大量研究也无法弄清楚为什么我会收到运行时错误1004“应用程序定义或对象定义错误。”

这是VBA代码：

Private Sub CommandButton1_Click()

    Dim HeaderList(1 To 4) As String, sheet As Worksheet, i As Integer, j As Integer, Summary As Worksheet

  'Define headers to look for
   HeaderList(1) = "Bananas"
   HeaderList(2) = "Puppies"
   HeaderList(3) = "Tigers"

    'Loop through each sheet looking for the right header
    For Each sheet In Workbooks("Tab Extraction Test.xlsm").Worksheets
        i = i + 1
        'Debug.Print i
        'Debug.Print HeaderList(i)
        Set h = Cells.Find(What:=HeaderList(i))

        With Worksheets("Summary")
            Worksheets("Summary").Cells(1, i).Value = h
        End With

        Col = h.Column
        Debug.Print Col
        Row = h.Row
        Debug.Print Row
        j = Row

        'Until an empty cell in encountered copy the value to a summary tab
        Do While IsEmpty(Cells(Col, j)) = False
            j = j + 1
            V = Range(Col, j).Value
            Debug.Print V
            Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary").Cells(j, i).Value = V

        Loop

    Next sheet

End Sub

错误发生在

Worksheets("Summary").Cells(1, i).Value = h

在其他帖子中，我认为这可能是因为我试图将某些内容添加到与当前循环中活动的单元格不同的单元格中，所以我添加了一个With语句，但无济于事。

提前感谢您的帮助。

Answer 1

按照上述评论，请尝试以下代码。

注意：我认为您的Cells(Row, Col)混淆了，我在下面的回答中尚未对其进行修改。我认为Cells(Col, j)应该是Cells(j, Col)，不是吗？

<强>代码

Option Explicit

Private Sub CommandButton1_Click()

    Dim HeaderList(1 To 4) As String, ws As Worksheet, i As Long, j As Long, Summary As Worksheet
    Dim h As Range, Col As Long

    'Define headers to look for
    HeaderList(1) = "Bananas"
    HeaderList(2) = "Puppies"
    HeaderList(3) = "Tigers"

    ' set the "Summary" tab worksheet
    Set Summary = Workbooks("Tab Extraction Test.xlsm").Worksheets("Summary")

    'Loop through each sheet looking for the right header
    For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
        With ws
            i = i + 1
            Set h = .Cells.Find(What:=HeaderList(i))

            If Not h Is Nothing Then ' successful find
                Summary.Cells(1, i).Value = h.Value

                j = h.Row
                'Until an empty cell in encountered copy the value to "Summary" tab
                ' Do While Not IsEmpty(.Cells(h.Column, j))
                Do While Not IsEmpty(.Cells(j, h.Column)) ' <-- should be
                    j = j + 1
                    Summary.Cells(j, i).Value = .Cells(j, h.Column).Value
                Loop
                Set h = Nothing ' reset range object
            End If
        End With
    Next ws

End Sub

Answer 2

试试这个。

Private Sub CommandButton1_Click()

    Dim HeaderList As Variant, ws As Worksheet, i As Integer, j As Integer, Summary As Worksheet
    Dim lastRow As Long, lastCol As Long, colNum As Long
    HeaderList = Array("Bananas", "Puppies", "Tigers", "Lions")

    For Each ws In Workbooks("Tab Extraction Test.xlsm").Worksheets
        lastCol = ws.Range("IV1").End(xlToLeft).Column
        For k = 1 To lastCol
            For i = 0 To 3
                Set h = ws.Range(Chr(k + 64) & "1").Find(What:=HeaderList(i))
                If Not h Is Nothing Then
                    lastRow = ws.Range(Chr(h.Column + 64) & "65536").End(xlUp).Row
                    colNum = colNum + 1
'                   The below line of code adds a header to summary page (row 1) showing which workbook and sheet the data came from
'                   If you want to use it then make sure you change the end of the follpowing line of code from "1" to "2"
'                   ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1").Value = Left(ws.Parent.Name, Len(ws.Parent.Name) - 5) & ", " & ws.Name
                    ws.Range(Chr(h.Column + 64) & "1:" & Chr(h.Column + 64) & lastRow).Copy Destination:=ThisWorkbook.Worksheets("Summary").Range(Chr(colNum + 64) & "1")
                    Exit For
                End If
            Next i
        Next k
    Next ws
End Sub

循环浏览工作表并提取数据时，Excel VBA运行时错误1004

2 个答案: