Subscript out of Range VBA

Question

Thanks for joining me, glad i am here

my problem is Subscript out of range when i am trying to copy and paste the data in individual tabs using with Offset option, i have given my code here

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

when i press the debug button then i go to the below line

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

kindly suggest me what is the mistake

Thanking you

here is the Final code which is changed but there is one problem that is it's copy only last row,

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

As per your instruction i change the code but i can't understand which to be remove when i run the code then i got the error code application is not defined here is the latest code

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

End Sub

if possible please give me the full code, what is my aim with above code is i have entered data in Dispatch Register with party wise and i have the different tabs as per the parties in the Dispatch Register when i run the code then the data will copy to their individual tabs without duplicate data

if any information you need then please ask me sir

Thanking You

With Regards

Answer 1

I'd add some code to handle possible error conditions and put in some debugging messages to work out what going on (or just examine some more variables in the debugger).

How about the following to get started.

    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

If I run this on a blank workbook (with a sheet named "Dispatch Register" I get the following in the "Immediate" debug window

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

In general, if something isn't working, it's best to expand out the code until it's easy to debug. For example,

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

would be easier to read and debug as

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