Runtime Errror 9 Subscript Out of Range

[VBAAccountant]

Hello, it's been a while since I've posted or done a macro so I apologize if I'm a bit rusty. I am getting a runtime error 9 on the below VBA...it fails at the line in red. I am actually getting the desired results, I'm just not sure how to get rid of the error.

Sub Copy_Row_To_Sheet_Cell_Value()
Application.ScreenUpdating = False
Dim i As Long
Sheets("Attorney Credited List").Activate
Dim Lastrow As Long
Lastrow = Sheets("Attorney Credited List").Cells(Rows.Count, "C").End(xlUp).Row
Dim Lastrowa As Long
Dim ans As String
For i = 2 To Lastrow
ans = Cells(i, "C").Value
Lastrowa = Sheets(ans).Cells(Rows.Count, "C").End(xlUp).Row + 1
Rows(i).Copy Destination:=Sheets(ans).Rows(Lastrowa)
Next

Exit Sub

End Sub

 

[Joe4]

See if this gets rid of the error:

Sub Copy_Row_To_Sheet_Cell_Value()

Application.ScreenUpdating = False
Dim i As Long
Sheets("Attorney Credited List").Activate
Dim Lastrow As Long
Lastrow = Sheets("Attorney Credited List").Cells(Rows.Count, "C").End(xlUp).Row
Dim Lastrowa As Long
Dim ans As Worksheet
For i = 2 To Lastrow
Set ans = Sheets(Cells(i, "C").Value)
Lastrowa = ans.Cells(ans.Rows.Count, "C").End(xlUp).Row + 1
Rows(i).Copy Destination:=ans.Rows(Lastrowa)
Next

Exit Sub

End Sub

 

[Alex Blakenburg]

@VBAAccountant your code works fine for me until such time as Column C has sheet name in it that doesn't match an actual sheet name.
Before the row it is erroring out on "Lastrowa =" copy in the line below:

Debug.Print "ans= ", ans, "Length ans=", Len(ans)

It will print each value of ans to the immediate window (Ctrl+G) if it is not visible.
The last one you see after it errors out will be the first invalid sheet name (you might have more)
Check that last value of ans in the immediat window against the actual expected sheet name to make sure it matches exactly.
Watch out for leading and trailing spaces (which is why included the length)

 

[DanteAmor]

Hello @VBAAccountant . Welcome back to the board.

With the following validation we verify if the sheet exists, if so we copy the row. If it does not exist, it will highlight the cell with the name of the sheet that does not exist in yellow.

If you don't mind, I tidied up your macro a bit:

Sub Copy_Row_To_Sheet_Cell_Value()
  Dim i As Long, Lastrowa As Long, Lastrow As Long
  Dim ans As String
  
  Application.ScreenUpdating = False
  
  With Sheets("Attorney Credited List")
    Lastrow = .Cells(Rows.Count, "C").End(xlUp).Row
    For i = 2 To Lastrow
      ans = .Cells(i, "C").Value
      If Evaluate("ISREF('" & ans & "'!A1)") Then
        Lastrowa = Sheets(ans).Cells(Rows.Count, "C").End(xlUp).Row + 1
        .Rows(i).Copy Destination:=Sheets(ans).Rows(Lastrowa)
      Else
        .Cells(i, "C").Interior.Color = vbYellow
      End If
    Next
  End With
  
  Application.ScreenUpdating = True
End Sub

If you have a lot of records in your sheet, this macro might be faster:

Sub Copy_Row_To_Sheet_Cell_Value_v2()
  Dim c As Range, sh As Worksheet, ky As Variant
  Dim dic As Object
  Dim lr As Long, lra As Long
  
  Application.ScreenUpdating = False
  
  Set sh = Sheets("Attorney Credited List")
  Set dic = CreateObject("Scripting.Dictionary")
  
  lr = sh.Range("C" & Rows.Count).End(xlUp).Row
  For Each c In sh.Range("C2:C" & lr)
    If c.Value <> "" Then dic.Item(c.Value) = c.Row
  Next c
  
  For Each ky In dic.Keys
    If Evaluate("ISREF('" & ky & "'!A1)") Then
      sh.Range("A1:C" & lr).AutoFilter 3, ky
      lr = Sheets(ky).Range("C" & Rows.Count).End(3).Row + 1
      sh.AutoFilter.Range.Offset(1).EntireRow.Copy Sheets(ky).Range("A" & lr)
    Else
      sh.Range("C" & dic(ky)).Interior.Color = vbYellow
    End If
    
  Next ky
  sh.ShowAllData
  
  Application.ScreenUpdating = True
End Sub

If you don't want to highlight the cell yellow, just remove the line from the macro:
.Cells(i, "C").Interior.Color = vbYellow or sh.Range("C" & dic(ky)).Interior.Color = vbYellow

--------------
Let me know the result and I'll get back to you as soon as I can.
Cordially
Dante Amor
--------------