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:

  1. Copies and pastes each row three times (to create four identical rows for each entry).
  2. 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

    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

  'Reset Macro Optimization Settings
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

End Sub
  • 4
    \$\begingroup\$ "not responding" isn't a warning. It just means the single-threaded Excel app is busy running your code and won't respond to user interactions. \$\endgroup\$ Dec 24, 2016 at 1:48
  • \$\begingroup\$ Is there a need to duplicate the list rather than looping over the original and then creating 5 identical worksheets from the single list? This would reduce the amount of copying of identical information. \$\endgroup\$
    – Eterm
    Dec 24, 2016 at 12:47

2 Answers 2


Here are my thoughts ( I'm using a tablet and so cannot test my suggestions). You are already turning off screen updating and calculations which is good.

  1. Avoid using Select where possible - there are plenty of examples of this.
  2. The Insert in your code is probably a very slow process because Excel does a lot of work. Why not simply copy the entire data in the columns you want and then paste four times onto another sheet? No need for the Insert or the 1,000 copy & pastes.
  3. Testing each row for the person's name to see if a worksheet exists and then copying just that row can also be changed. Why not sort the data by name, then run down the data keeping track of start row of current name and looking to see when the name changes? Then you copy the data from the start row up to the row before the current one. That way you could do just one copy & paste per name into the named worksheet.
  • \$\begingroup\$ Thanks for the input. For one I decided to break the code into two subs (thinking that if errors occurred it would be better to have two subs rather than one). For suggestion 2 I looked into how to do this but am stuck. Would it easier to just filter column A (successively) by each unique name and copy that filtered data four times into a separate ws? I am still researching the code to do this (rather new to VBA). Finally, thought that passing this into an array might be better but I have less know how of that than coding for a filter. Thanks for any additional input. \$\endgroup\$
    – Andes2016
    Dec 29, 2016 at 2:55
  • \$\begingroup\$ My point 2) was that do one 'Copy' command and then four 'Paste' commands onto the same worksheet to produce four copies of the same data. Then in step 3), sort that data by name and write to the new single worksheets. \$\endgroup\$ Jan 4, 2017 at 13:33

Standard VBA naming conventions have camelCase for local variables and PascalCase for other variables and names. You seem to be using some hungarian notation and Variable names - give your variables meaningful names:

Const NAME_COLUMN As String = "A"
Const HEADER_ROW As Long = 1
Const FIRST_ROW As Long = 2
Dim sourceSheet As Worksheet
Dim targetSheet As Worksheet
Dim sourceRowIndex As Long
Dim lastRow As Long
Dim targetRow As Long
Dim person As String
Dim rowCounter As Long
Dim repeatFactor As Variant

Comments and labels

I don't see a need for the label ResetSettings:. Also your comments aren't needed - Comments - "code tell you how, comments tell you why". The code should speak for itself, if it needs a comment, it might need to be made more clear. If not, the comment should describe why you're doing something rather than how you're doing it. Here are a few reasons to avoid comments all together.

Select and copy

Be sure to avoid things like .Select - it just slows the code down by needing to fiddle with the spreadsheet while doing everything else behind the scenes. There's a good question on StackOverflow addressing this.

You can completely avoid the copy

sourceSheet.Rows(sourceRowIndex).Copy Destination:=targetSheet.Rows(targetRow)

By doing this instead:

targetSheet.Rows(targetRow) = sourceSheet.Rows(sourceRowIndex).Value

This is overly complicated -

Do While (Cells(rowCounter, "B") <> "")

You can use

Do While Not IsEmpty(Cells(rowCounter, "B"))

What if activesheet isn't your target?

Set sourceSheet = ActiveSheet

Try to be more explicit.



    On Error Resume Next
    Set targetSheet = Worksheets(person)
    On Error GoTo 0
    If targetSheet Is Nothing Then

Has a better way

If Not WorksheetExists(person) then
    Set targetSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
    targetSheet.Name = person
    targetSheet.Rows(HEADER_ROW) = sourceSheet.Rows(HEADER_ROW).Value
 End If

Function WorksheetExists(sName As String) As Boolean
    WorksheetExists = Evaluate("ISREF('" & sName & "'!A1)")
End Function

Duplicating Rows

There's an easier way to duplicate your rows as well

Sub DuplicateRows()
    Dim lastRow As Long
    lastRow = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
    Dim i As Long
    Dim j As Long
    For i = lastRow To 1 Step -1
        For j = 1 To 3
            Sheet1.Rows(i).Insert shift:=xlDown
            Sheet1.Rows(i) = Sheet1.Rows(i + 1).Value
End Sub

However, why don't you duplicate them once they are already moved to the new sheet, that way you iterate over 1000 instead of 4000?


Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.