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

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

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

所有这些假设都基于您打开的每个工作簿都有“违规摘要”表并且其拼写如下所示的假设。

您已经将文件名存储在变量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。 row.Columns(3)是写row.Columns(3)的一种好方法row.Cells(1, 3)它引用目标行中的第三个单元格。 还要注意，单元格，列和行都相对于它们所属的范围。 例如Range("C1").Columns(2)引用D1 ， Range("C1").Rows(2).Columns(2)引用D2 ， Range("C1").Cells(2,2)指D2 。