首页 文章

下标超出范围VBA

提问于
浏览 次
0

感谢您加入我，很高兴我来到这里

当我尝试使用Offset选项将数据复制并粘贴到各个选项卡中时，我的问题是下标超出范围，我在这里给出了我的代码

Private Sub CommandButton1_Click()
Call UnprotectSheets
Dim i As Long, a As Long, counter As Long
    Dim lastrow As Long, c As Range
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    counter = 0
    For i = 2 To Sheets.Count
        If Sheets(i).Range("C6") = "" Then
            a = 0
        Else
            a = Sheets(i).Range("C6", Sheets(i).Range("C6").End(xlDown)).Rows.Count
        End If
        counter = counter + a
    Next i
    If counter = Sheets("Dispatch Register").Range("C6", Sheets("Dispatch Register").Range("C6").End(xlDown)).Rows.Count Then MsgBox "No new entries!": Exit Sub
    With Sheets("Dispatch Register")
        lastrow = .Cells(.Rows.Count, 3).End(xlUp).Row
        For Each c In Range("F6:F" & lastrow)
            c.Offset(, -3).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(1)
            c.Offset(, 1).Resize(, 3).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 2)
            c.Offset(, 5).Resize(, 4).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 5)
            c.Offset(, -4).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 10)
            c.Offset(, 10).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 11)
        Next c
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Call ProtectSheets
End Sub

当我按下调试按钮然后我转到下面的行

c.Offset(, -3).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(1)

请告诉我什么是错误

感谢您

这里是最终的代码，但是有一个问题就是它只复制到最后一行，

Private Sub CommandButton1_Click()
    Call UnprotectSheets
             Dim i As Long, a As Long, counter As Long
            Dim lastrow As Long, c As Range

            Application.Calculation = xlCalculationManual
            Application.ScreenUpdating = False

            Call UnprotectSheets
            counter = 0
            For i = 2 To Sheets.Count
                With Sheets(i)
                     If .Range("C6") = "" Then
                        a = 0
                     ElseIf .Range("C7") = "" Then
                        a = 1
                     Else
                        a = .Range("C6", .Range("C6").End(xlDown)).Rows.Count
                     End If
                     counter = counter + a
                End With
            Next i

            If counter = Sheets("Dispatch Register").Range("C6", Sheets("Dispatch Register").Range("C6").End(xlDown)).Rows.Count Then MsgBox "No new entries!": Exit Sub

            With Sheets("Dispatch Register")
                 lastrow = .Cells(.Rows.Count, 3).End(xlUp).Row
                 For Each c In .Range("F" & (counter + 6) & ":F" & lastrow)
                     If c <> "" Then
                     If SheetExists(c.Text) Then
                        c.Offset(, -3).Resize(, 2).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(1)
                        c.Offset(, 1).Resize(, 3).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 2)
                        c.Offset(, 5).Resize(, 4).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 5)
                        c.Offset(, -4).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 10)
                        c.Offset(, 10).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 11)
        Else
          Debug.Print "Sheet: '" & c.Text & "' not found"
        End If
        End If
       Next c
    End With
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Call ProtectSheets
End Sub

根据你的指示我更改代码，但我无法理解当我运行代码时要删除哪个，然后我得到错误代码应用程序未定义这里是最新的代码

Private Sub CommandButton1_Click（）调用UnprotectSheets Dim i As Long，a Long，counter as Long Dim lastrow As Long，c As Range

Application.Calculation = xlCalculationManual
        Application.ScreenUpdating = False

        Call UnprotectSheets
        counter = 0
        For i = 2 To Sheets.Count
           With Sheets(i)
                 If .Range("C6") = "" Then
                    a = 0
                 ElseIf .Range("C7") = "" Then
                    a = 1
                 Else
                    a = .Range("C6", .Range("C6").End(xlDown)).Rows.Count
                 End If
                 counter = counter + a
            End With
        Next i

       ' If counter = Sheets("Dispatch Register").Range("C6", Sheets("Dispatch Register").Range("C6").End(xlDown)).Rows.Count Then MsgBox "No new entries!": Exit Sub
        lastCell = Sheets("Dispatch Register").Range("C6").End(xlDown)
        counter = Sheets("Dispatch Register").Range("C6", lastCell).Rows.Count

        If Count = 0 Then
        MsgBox "No new entries!"
        Exit Sub
        End If

        With Sheets("Dispatch Register")
             lastrow = .Cells(.Rows.Count, 3).End(xlUp).Row
             For Each c In .Range("F" & (counter + 6) & ":F" & lastrow)
                 If c <> "" Then
                 If SheetExists(c.Text) Then
                    c.Offset(, -3).Resize(, 2).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(1)
                    c.Offset(, 1).Resize(, 3).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 2)
                    c.Offset(, 5).Resize(, 4).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 5)
                    c.Offset(, -4).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 10)
                    c.Offset(, 10).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 11)
    Else
      Debug.Print "Sheet: '" & c.Text & "' not found"
    End If
    End If
   Next c
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Call ProtectSheets

结束子

如果可能的话请给我完整的代码，上面的代码是什么我的目的是我已经在派遣登记册中输入了数据，并且当我运行代码时我根据调度寄存器中的各方有不同的选项卡然后数据将复制到各个选项卡而不重复数据

如果您需要任何信息，请先问我

感谢您

带着敬意

vba subscript

1 回答

  • 0

    我将添加一些代码来处理可能的错误条件，并输入一些调试消息来计算出发生了什么（或者只是在调试器中检查一些更多的变量） .

    如何开始以下内容 .

    lastrow = .Cells(.Rows.Count, 3).End(xlUp).Row
    Debug.Print "lastrow: " & lastrow
    For Each c In Range("F6:F" & lastrow)
        If SheetExists(c.Text) Then
            c.Offset(, -3).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(.Rows.Count, "B").End(xlUp).Offset(1)
            c.Offset(, 1).Resize(, 3).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 2)
            c.Offset(, 5).Resize(, 4).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 5)
            c.Offset(, -4).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 10)
            c.Offset(, 10).Resize(, 1).Copy ThisWorkbook.Sheets(c.Text).Cells(Rows.Count, "B").End(xlUp).Offset(0, 11)
        Else
          Debug.Print "Sheet: '" & c.Text & "' not found"
        End If
    Next c


Function SheetExists(sheetName As String) As Boolean
  SheetExists = False
  For Each ws In Worksheets
    If sheetName = ws.Name Then
      SheetExists = True
      Exit Function
    End If
  Next ws
End Function

    如果我在一个空白工作簿上运行它（带有一个名为“Dispatch Register”的工作表，我在“立即”调试窗口中得到以下内容

    lastrow: 1 
Sheet: '' not found 
Sheet: '' not found 
Sheet: '' not found 
Sheet: '' not found 
Sheet: '' not found 
Sheet: '' not found

    通常，如果某些东西不起作用，最好扩展代码，直到它易于调试 . 例如，

    If counter = Sheets("Dispatch Register").Range("C6", Sheets("Dispatch Register").Range("C6").End(xlDown)).Rows.Count Then MsgBox "No new entries!": Exit Sub

    会更容易阅读和调试

    lastCell = Sheets("Dispatch Register").Range("C6").End(xlDown)
counter = Sheets("Dispatch Register").Range("C6", lastCell).Rows.Count

If Count = 0 Then
    MsgBox "No new entries!"
    Exit Sub
End If
    回复于

相关问题