Subscript out of Range VBA - 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