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

Question

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

моя проблема является Подстрочной вне диапазона, когда я пытаюсь копировать и вставлять данные в отдельных вкладках, используя с 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 я As Long, A A s Long, счетчик As Long Dim lastrow As Long, с 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 

End Sub

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

Если у вас есть какая-либо информация, пожалуйста, спросите меня, сэр

Благодарим Вас

С уважением

Answer 1

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

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

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 

Если я бегу это на пустой книги (с листом под названием «Отправка Регистр» Я получаю следующее в «Immediate» отладки окна

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