The following code trowing run time error when it encountered 1st change in column "D" and stopping after 1st sheet is created.
Sub copy_rows_to_sheets()
Dim firstrow, lastrow, r, torow As Integer
Dim fromsheet, tosheet As Worksheet
firstrow = 2
Set fromsheet = ActiveSheet
lastrow = ActiveSheet.Cells(Rows.Count, "D").End(xlUp).Row
For r = firstrow To lastrow
If fromsheet.Cells(r, "B") <> "" Then 'skip rows where column D is empty
On Error GoTo make_new_sheet
Set tosheet = Worksheets("" & fromsheet.Cells(r, "D"))
On Error GoTo 0
GoTo copy_row
make_new_sheet:
Set tosheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
tosheet.Name = fromsheet.Cells(r, "D")
copy_row:
torow = tosheet.Cells.SpecialCells(xlCellTypeLastCell).Row + 1
fromsheet.Cells(r, 1).EntireRow.Copy
tosheet.Cells(torow, 1).PasteSpecial Paste:=xlPasteValues
End If
Next r
Application.CutCopyMode = False
fromsheet.Activate
End Sub
Someone Help please..
