Creating new sheet with rows from source sheet when ever value changes in column D of source sheet

%3CLINGO-SUB%20id%3D%22lingo-sub-1491229%22%20slang%3D%22en-US%22%3ECreating%20new%20sheet%20with%20rows%20from%20source%20sheet%20when%20ever%20value%20changes%20in%20column%20D%20of%20source%20sheet%3C%2FLINGO-SUB%3E%3CLINGO-BODY%20id%3D%22lingo-body-1491229%22%20slang%3D%22en-US%22%3E%3CP%3EI%20am%20having%20a%20sheet%20of%2020k%20plus%20rows(Source%20Sheet).%20It%20is%20sorted%20on%20column%20%22D%22.%20Basing%20on%20the%20values%20in%20column%20%22D%22%20I%20would%20like%20to%20create%20separate%20sheet%20for%20the%20rows%20having%20same%20values%20in%20column%20%22D%22.%20i.e.%2C%20a%20new%20sheet%20is%20created%20as%20and%20when%20a%20change%20in%20value%20is%20encountered.%26nbsp%3B%20I%20want%20to%20name%20the%20new%20sheet%20with%20relevant%20value%20from%20column%20%22D%22.%26nbsp%3B%20Give%20me%20a%20macro%20please.%3C%2FP%3E%3C%2FLINGO-BODY%3E%3CLINGO-LABS%20id%3D%22lingo-labs-1491229%22%20slang%3D%22en-US%22%3E%3CLINGO-LABEL%3EMacros%20and%20VBA%3C%2FLINGO-LABEL%3E%3C%2FLINGO-LABS%3E
Highlighted
New Contributor

I am having a sheet of 20k plus rows(Source Sheet). It is sorted on column "D". Basing on the values in column "D" I would like to create separate sheet for the rows having same values in column "D". i.e., a new sheet is created as and when a change in value is encountered.  I want to name the new sheet with relevant value from column "D".  Give me a macro please.

1 Reply
Highlighted

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..