Подстрочный индекс вне диапазона VBA

Спасибо, что присоединились ко мне, рад, что я здесь

моя проблема заключается в том, что нижний индекс выходит за пределы допустимого диапазона, когда я пытаюсь скопировать и вставить данные на отдельных вкладках, используя параметр смещения, я привел здесь свой код

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 () 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
        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
person user2998753    schedule 16.11.2013    source источник
comment
Я удалил вашу подпись из вашего вопроса, если вы хотите, чтобы ваши сообщения были связаны с вашим именем, отредактируйте свой профиль или создайте новую учетную запись.   -  person Robin Green    schedule 16.11.2013
comment
Спасибо, Робин, за редактирование моей подписи   -  person user2998753    schedule 16.11.2013

Ответы (1)


arrow_upward
0
arrow_downward

Я бы добавил код для обработки возможных условий ошибки и вставил несколько отладочных сообщений, чтобы выяснить, что происходит (или просто исследовал еще несколько переменных в отладчике).

Как насчет следующего, чтобы начать работу.

    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

Если я запустил это в пустой книге (с листом с именем «Диспетчерский регистр», я получу следующее в окне «Немедленная» отладки

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
person grantnz    schedule 16.11.2013
comment
Здравствуйте, спасибо за ваш быстрый ответ в соответствии с вашим кодом отладки i, есть одна вкладка, не совпадающая, поэтому возникает ошибка - person user2998753; 16.11.2013
comment
Здравствуйте, мне нужна небольшая модификация, то есть я хочу предотвратить дублирование копии, поэтому я добавляю строку счета, но она не работает, не могли бы вы помочь, как это сделать, если counter = Sheets (Dispatch Register) .Range (C6, Sheets (Dispatch) Register) .Range (C6) .End (xlDown)). Rows.Count Then MsgBox Нет новых записей !: Exit Sub With Sheets (Dispatch Register) lastrow = .Cells (.Rows.Count, 3) .End (xlUp). Строка для каждого c в диапазоне (F6: F и последняя строка) - person user2998753; 16.11.2013
comment
Попробуйте поместить присвоение счетчику в отдельную строку, если счетчик = 0, то .... Вам также может потребоваться разбить назначение счетчика на большее количество операторов, чтобы понять, что происходит. - person grantnz; 16.11.2013
comment
Здравствуйте, спасибо за ваш ответ и извините, что доставили вам боль, если вы не против, пожалуйста, предоставьте мне полный код, потому что я не могу изменить код, который вы дали, поэтому, если возможно, исправьте меня, указав полный код. - person user2998753; 17.11.2013
comment
У меня больше нет полного кода, но предложенные мной изменения работают. Какая часть дает вам ошибки? - person grantnz; 17.11.2013
comment
сэр любезно помогите мне в этом вопросе - person user2998753; 20.11.2013
comment
Ваш код очень специфичен для данных электронной таблицы, с которыми вы работаете, и вы не указали на эти данные. Вам действительно нужно лучше изолировать проблему и задать еще один вопрос. Постарайтесь точно выяснить, что происходит не так, и сделать это самостоятельно, без всего кода, который работает правильно. Посетите sscce.org для получения дополнительной информации о том, что необходимо. - person grantnz; 21.11.2013
comment
Спасибо Q, сэр, в соответствии с вашими руководящими принципами я опубликую еще один вопрос. С уважением. - person user2998753; 21.11.2013