Forum Discussion
Copying master sheet rows to sheets based on column - modify VBA to only copy new added rows?
I have a 'master sheet' that gets added to (by copying new rows to it) on a monthly basis (100's of rows per month). I was able to build a module that adds a sheet and copies rows to the new sheet based on a column in master sheet, with the new sheet named the value of the column. It works great running first time to create and populate all the other sheets. Now, I would like to modify the module to ONLY copy the newly added sheets each month. I'm not sure it can be modified, I've tried a number of things, but no luck getting it to work. There will NOT be any new values in source column, so no need to create new sheets. Here's the initial populate module. TIA, Curtis
==============
Sub Copy_Rows()
Dim r1 As Range, Row_Last As Long, sht As Worksheet
Dim Row_Last1 As Long
Dim RangeName As String
Dim src As Worksheet
'source sheet
Set src=Sheets("DirPrnInfo_CD's Cleaned")
Row_Last = src.Cells(Cells.Rows.Count, "A").End(xlUp).Row
RangeName = "A2:" & "A" & Row_Last
For Each r1 In src.Range(RangeName)
On Error Resume Next
Set sht = Sheets(CStr(r1.Value))
On Error GoTo 0
If sht Is Nothing Then
Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r1.Value)
'Sheets(CStr(r.Value)).Cells(1, 1) = "Total"
Row_Last1 = Sheets(CStr(r1.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
src.Rows(r1.Row).Copy Sheets(CStr(r1.Value)).Cells(Row_Last1 + 1, 1)
Sheets(CStr(r1.Value)).Cells(1, 2) = WorksheetFunction.Sum(Sheets(CStr(r1.Value)).Columns(8))
Set sht = Nothing
Else
'Sheets(CStr(r.Value)).Cells(1, 1) = "Total"
Row_Last1 = Sheets(CStr(r1.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row
src.Rows(r1.Row).Copy Sheets(CStr(r1.Value)).Cells(Row_Last1 + 1, 1)
Sheets(CStr(r1.Value)).Cells(1, 2) = WorksheetFunction.Sum(Sheets(CStr(r1.Value)).Columns(8))
Set sht = Nothing
End If
Next r1
End Sub
===================
There is only a slight modification to your code and it works in the attached file if an identifier is added in column I. Let's say that the newly added rows of data are in range A100:H250. Then i add e.g. an "x" as identifier in cell I100 since 100 is the start row of the added data. Your code then only adds the data from A100:H250 to the already existing sheets.
Sub Copy_Rows() Dim r1 As Range, Row_Last, Row_First As Long, sht As Worksheet Dim Row_Last1 As Long Dim RangeName As String Dim src As Worksheet 'source sheet Set src=Sheets("DirPrnInfo_CD's Cleaned") Row_Last = src.Cells(Cells.Rows.Count, "A").End(xlUp).Row Row_First = src.Cells(Cells.Rows.Count, "I").End(xlUp).Row If Row_First = 1 Then Row_First = 2 Else End If RangeName = "A" & Row_First & ":A" & Row_Last For Each r1 In src.Range(RangeName) On Error Resume Next Set sht = Sheets(CStr(r1.Value)) On Error GoTo 0 If sht Is Nothing Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r1.Value) 'Sheets(CStr(r.Value)).Cells(1, 1) = "Total" Row_Last1 = Sheets(CStr(r1.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row src.Rows(r1.Row).Copy Sheets(CStr(r1.Value)).Cells(Row_Last1 + 1, 1) Sheets(CStr(r1.Value)).Cells(1, 2) = WorksheetFunction.Sum(Sheets(CStr(r1.Value)).Columns(8)) Set sht = Nothing Else 'Sheets(CStr(r.Value)).Cells(1, 1) = "Total" Row_Last1 = Sheets(CStr(r1.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row src.Rows(r1.Row).Copy Sheets(CStr(r1.Value)).Cells(Row_Last1 + 1, 1) Sheets(CStr(r1.Value)).Cells(1, 2) = WorksheetFunction.Sum(Sheets(CStr(r1.Value)).Columns(8)) Set sht = Nothing End If Next r1 End Sub
2 Replies
There is only a slight modification to your code and it works in the attached file if an identifier is added in column I. Let's say that the newly added rows of data are in range A100:H250. Then i add e.g. an "x" as identifier in cell I100 since 100 is the start row of the added data. Your code then only adds the data from A100:H250 to the already existing sheets.
Sub Copy_Rows() Dim r1 As Range, Row_Last, Row_First As Long, sht As Worksheet Dim Row_Last1 As Long Dim RangeName As String Dim src As Worksheet 'source sheet Set src=Sheets("DirPrnInfo_CD's Cleaned") Row_Last = src.Cells(Cells.Rows.Count, "A").End(xlUp).Row Row_First = src.Cells(Cells.Rows.Count, "I").End(xlUp).Row If Row_First = 1 Then Row_First = 2 Else End If RangeName = "A" & Row_First & ":A" & Row_Last For Each r1 In src.Range(RangeName) On Error Resume Next Set sht = Sheets(CStr(r1.Value)) On Error GoTo 0 If sht Is Nothing Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = CStr(r1.Value) 'Sheets(CStr(r.Value)).Cells(1, 1) = "Total" Row_Last1 = Sheets(CStr(r1.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row src.Rows(r1.Row).Copy Sheets(CStr(r1.Value)).Cells(Row_Last1 + 1, 1) Sheets(CStr(r1.Value)).Cells(1, 2) = WorksheetFunction.Sum(Sheets(CStr(r1.Value)).Columns(8)) Set sht = Nothing Else 'Sheets(CStr(r.Value)).Cells(1, 1) = "Total" Row_Last1 = Sheets(CStr(r1.Value)).Cells(Cells.Rows.Count, "A").End(xlUp).Row src.Rows(r1.Row).Copy Sheets(CStr(r1.Value)).Cells(Row_Last1 + 1, 1) Sheets(CStr(r1.Value)).Cells(1, 2) = WorksheetFunction.Sum(Sheets(CStr(r1.Value)).Columns(8)) Set sht = Nothing End If Next r1 End Sub- This worked like a champ! Simple solution, very 'elegant'!
Thanks, Curtis
