I have a worksheet that lists a person's name (column A; many duplicate names are in this column) with associated data (columns B through G). I have code below that takes this list of a ~ 1000 rows and then:
- Copies and pastes each row three times (to create four identical rows for each entry).
- Loops through the now ~4000 rows and creates a new worksheet for each person. As there are many duplicate names in column A this only creates a handful of new worksheets.
The thing is, it runs but runs quite slowly (and I receive the Excel not responding warning at times). Is there anything to clean this up to make it more efficient? And after this I run another macro to save the new worksheets to a new workbook. Would it be faster to do that with code here?
Sub Split_Data() Const NameCol = "A" Const HeaderRow = 1 Const FirstRow = 2 Dim SrcSheet As Worksheet Dim TrgSheet As Worksheet Dim SrcRow As Long Dim LastRow As Long Dim TrgRow As Long Dim person As String Dim lRow As Long Dim RepeatFactor As Variant 'Optimize Macro Speed Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual 'Copy each row and paste three times lRow = 2 Do While (Cells(lRow, "B") <> "") RepeatFactor = 4 Range(Cells(lRow, "A"), Cells(lRow, "G")).Copy Range(Cells(lRow + 1, "A"), Cells(lRow + RepeatFactor - 1, "G")).Select Selection.Insert Shift:=xlDown lRow = lRow + RepeatFactor - 1 lRow = lRow + 1 Loop Set SrcSheet = ActiveSheet LastRow = SrcSheet.Cells(SrcSheet.Rows.Count, NameCol).End(xlUp).Row For SrcRow = FirstRow To LastRow person = SrcSheet.Cells(SrcRow, NameCol).Value Set TrgSheet = Nothing On Error Resume Next Set TrgSheet = Worksheets(person) On Error GoTo 0 If TrgSheet Is Nothing Then Set TrgSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count)) TrgSheet.Name = person SrcSheet.Rows(HeaderRow).Copy Destination:=TrgSheet.Rows(HeaderRow) End If TrgRow = TrgSheet.Cells(TrgSheet.Rows.Count, NameCol).End(xlUp).Row + 1 SrcSheet.Rows(SrcRow).Copy Destination:=TrgSheet.Rows(TrgRow) Next SrcRow ResetSettings: 'Reset Macro Optimization Settings Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub