VBA错误：运行时错误：9 - 从另一个工作簿复制工作表时下标超出范围

Question

我正在从多个工作簿生成一个新工作簿，我可以生成所有找到的错误的摘要，但是当我尝试使用错误信息复制工作表时，我得到了运行时错误9

这些线路失败

                    If exists = True Then
                        ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
                    End If

我没有添加的其他内容是多个文件上的所有工作表都具有相同的名称，所以我想知道是否有一种方式，表单何时复制我可以添加文件名和工作表名称

Sub getViolations()
Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
Filename = Dir(Path & "*.xls")

    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set TxtRng = ws.Range("A1:N1")
    TxtRng.Font.ColorIndex = 2
    TxtRng.Interior.ColorIndex = 5
    TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
    TxtRng.HorizontalAlignment = xlCenter
    Dim i As Integer
    i = 2
    Do While Filename <> ""
        Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
        Dim wc As Worksheet
        Set wc = ActiveWorkbook.Sheets("Violations Summary")

        ws.Cells(i, 1).Value = ActiveWorkbook.Sheets("Violations Summary").Range("B1")
        ws.Cells(i, 2).Value = ActiveWorkbook.Sheets("Violations Summary").Range("C1")


        Dim count As Integer
        count = 15
        Dim sheetName As String, mySheetNameTest As String
        Dim n As Integer
        Dim exits As Boolean

        For n = 3 To 14

            If Not IsEmpty(wc.Cells(n, 2)) Then

                If (wc.Cells(n, 2)) = 0 Then
                    ws.Cells(i, n).Font.ColorIndex = 4
                    ws.Cells(i, n).Value = wc.Cells(n, 2)

                End If
                If (wc.Cells(n, 2)) > 0 Then


                    Select Case wc.Cells(n, 1)

                    Case "PK"
                       sheetName = "Peak"
                    Case "Sfactor"
                        sheetName = "SF Supply"
                    Case Else
                       sheetName = wc.Cells(n, 1)
                    End Select
                    exists = sheetExists(sheetName)
                    If exists = True Then
                        ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
                    End If

                    ws.Cells(i, count) = wc.Cells(1, n).Value
                    ws.Cells(i, n).Font.ColorIndex = 3
                    ws.Cells(i, n).Value = wc.Cells(n, 2)

                End If
                If (ActiveWorkbook.Sheets("Violations Summary").Cells(n, 2)) < 0 Then
                    ws.Cells(i, n).Font.ColorIndex = 3
                    ws.Cells(i, n).Value = wc.Cells(n, 2)

                End If

            End If

            If IsEmpty(wc.Cells(n, 2)) Then
                ws.Cells(i, n).Value = ["NA"]
            End If
            count = count + 1
        Next n

        Workbooks(Filename).Close
        Filename = Dir()
    i = i + 1
    Loop

End Sub


Function sheetExists(sheetToFind As String) As Boolean
    sheetExists = False
    For Each Sheet In Worksheets
        If sheetToFind = Sheet.Name Then
            sheetExists = True
            Exit Function
        End If
    Next Sheet
End Function

Answer 1

将选项显式置于顶部，以便检查变量的拼写并声明它们。存在的变量是mispelt，并且还有许多其他未声明的变量。我在代码中添加了一些其他注释。

我认为可以简化一些逻辑，我给出了一些例子。另外，确保命名变量wc的一致使用。如果没有别的，现在应该更容易调试。在我的机器上编译，试试吧。

这一切都假设您打开的每个工作簿都有＆＃34;违规摘要＆＃34;表格，拼写如图所示。

您的文件名已经存储在变量Filename中，因此您可以使用（连接？）和sheetname变量。

Option Explicit 'Set this to ensure all variable declared and consistent spelling
'Consider using WorkSheets collection rather than Sheets unless you have chart sheets as well?
Sub getViolations()
    Dim Path As String 'Declare you other variables
    Dim FileName As String

    Path = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
    FileName = Dir(Path & "*.xls")

    Dim ws As Worksheet
    Dim TxtRng As Range 'Declare this
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Set TxtRng = ws.Range("A1:N1")
    TxtRng.Font.ColorIndex = 2
    TxtRng.Interior.ColorIndex = 5
    TxtRng.Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
    TxtRng.HorizontalAlignment = xlCenter

    Dim i As Integer

    i = 2

    Do While FileName <> ""

        Workbooks.Open FileName:=Path & FileName, ReadOnly:=True

        Dim wc As Worksheet 'Consider whether to place these declarations just before the loop, avoids risk others may think there will be reinitialization even though there isn't

        Set wc = ActiveWorkbook.Sheets("Violations Summary")
        ws.Cells(i, 1).Value = wc.Range("B1") 'Use the wc variable
        ws.Cells(i, 2).Value = wc.Range("C1")

        Dim count As Integer
        Dim sheetName As String, mySheetNameTest As String
        Dim n As Integer
        Dim exists As Boolean 'Corrected spelling

        count = 15

        For n = 3 To 14

            If Not IsEmpty(wc.Cells(n, 2)) Then

                If (wc.Cells(n, 2)) = 0 Then
                    ws.Cells(i, n).Font.ColorIndex = 4
                    ws.Cells(i, n).Value = wc.Cells(n, 2)
                End If

                If (wc.Cells(n, 2)) > 0 Then

                    Select Case wc.Cells(n, 1)
                        Case "PK"
                            sheetName = "Peak"
                        Case "Sfactor"
                           sheetName = "SF Supply"
                        Case Else
                          sheetName = wc.Cells(n, 1)
                    End Select

                    exists = sheetExists(sheetName)

                    If exists Then  'Shortened by removing = True (evaluates in same way)
                        ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)
                    End If

                    ws.Cells(i, count) = wc.Cells(1, n).Value
                    ws.Cells(i, n).Font.ColorIndex = 3
                    ws.Cells(i, n).Value = wc.Cells(n, 2)

                End If

                If (wc.Cells(n, 2)) < 0 Then 'used wc variable
                    ws.Cells(i, n).Font.ColorIndex = 3
                    ws.Cells(i, n).Value = wc.Cells(n, 2)
                End If

            Else  'Simplified this as if is not empty then is empty so can use else
                ws.Cells(i, n).Value = ["NA"] 'what is pupose of square brackets? These can be removed i think
            End If
            count = count + 1
        Next n

        Workbooks(FileName).Close
        FileName = Dir()
    i = i + 1
    Loop

End Sub


Function sheetExists(sheetToFind As String) As Boolean
    Dim Sheet As Worksheet ' declare
    sheetExists = False

    For Each Sheet In Worksheets
        If sheetToFind = Sheet.Name Then
            sheetExists = True
            Exit Function
        End If
    Next Sheet

End Function

Answer 2

将ActiveWorkbook.Sheets(sheetName)复制到ThisWorkbook后，ThisWorkbook成为ActiveWorkbook。 ActiveWorkbook.Sheets(sheetName).Copy After:=ThisWorkbook.Sheets(1)不应抛出错误，但可能会导致ActiveWorkbook.Sheets("Violations Summary")失败。因此，您应该始终完全限定您的参考资料。

一些理想主义程序员说子程序应该只执行1个任务。就个人而言，我相信如果你必须向上，向下，向左或向右滚动以查看你的代码正在做什么，那么现在是重构它的时候了。在重构时，我尝试在单独的子例程中提取逻辑任务组。这使得调试和修改代码变得更加容易。

重构代码

Option Explicit

Sub getViolations()
    Const Path As String = "C:\Users\omartinr\Desktop\New folder (4)\New folder\"
    Dim n As Long
    Dim Filename As String
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Sheets("Sheet1")
    Sheet1Setup ws
    Filename = Dir(Path & "*.xls")

    Do While Filename <> ""
        ProcessWorkbook Filename, ws.Rows(n)
        Filename = Dir()
    Loop
End Sub

Sub ProcessWorkbook(WBName As String, row As Range)
    Dim nOffset As Long, n As Long
    Dim sheetName As String
    Dim WB As Workbook

    Set WB = Workbooks.Open(Filename:=Path & Filename, ReadOnly:=True)
    With WB.Sheets("Violations Summary")
        row.Columns(1).Value = .Range("B1")
        row.Columns(2).Value = .Range("C1")
        nOffset = 12
        For n = 3 To 14
            If .Cells(n, 2) = "" Then
                row.Columns(n).Value = ["NA"]
            ElseIf (.Cells(n, 2)) = 0 Then
                row.Columns(n).Font.ColorIndex = 4
                row.Columns(n).Font.ColorIndex = 0
            ElseIf (.Cells(n, 2)) = 0 Then
                Select Case wc.Cells(n, 1)
                    Case "PK"
                        sheetName = "Peak"
                    Case "Sfactor"
                        sheetName = "SF Supply"
                    Case Else
                        sheetName = wc.Cells(n, 1)
                End Select
                'Range.Parent refers to the ranges worksheet.  row.Parent refers to ThisWorkbook.Sheets(1)
                If SheetExists(WB, sheetName) Then .Copy After:=row.Parent.Sheets(1)
                row.Columns(n + nOffset) = .Cells(1, n).Value
                row.Columns(n).Font.ColorIndex = 3
                row.Columns(n).Value = .Cells(n, 2)
            End If
        Next
    End With
    WB.Close SaveChanges:=False
End Sub

Function SheetExists(WB As Workbook, sheetToFind As String) As Boolean
    Dim ws As Worksheet
    For Each ws In WB.Worksheets
        If sheetToFind = ws.Name Then
            SheetExists = True
            Exit Function
        End If
    Next
End Function

Sub Sheet1Setup(ws As Worksheet)
    With ws.Range("A1:N1")
        .Value = [{"Partition Name","Tag","EM Supply","SH Signal","PK","Sfactor","FiSH","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL","RESCAL"}]
        .Font.ColorIndex = 2
        .Interior.ColorIndex = 5
        .HorizontalAlignment = xlCenter
    End With
End Sub

注意：row是ThisWorkbook.Sheets(1)的目标行。 row.Columns(3)是一种写入row.Cells(1, 3)的奇特方式，它引用目标行中的第3个单元格。另请注意，单元格，列和行都与它们所属的范围相关。例如Range("C1").Columns(2)表示D1，Range("C1").Rows(2).Columns(2)表示D2，Range("C1").Cells(2,2)表示D2。