Add new sheet per unique value in column A and copy data (along with header) to respective new sheets

[mkseto]

I've been using the below macro for several months with no issues until recently ..... no error returned but it keeps spinning!!
I finally figured out the problem: for the first few months, the workbooks had only about 100-200 rows, but recently due to merger of various positions, the workbooks now contain as much as 500,000 rows, and the large number of rows appears to have bogged down the macro. I played with reducing the number of rows and it seems to be fine for up to a few hundred rows, but the macro starts to slow down as the number increases. Can anyone help to make the macro more effective in handling large number of rows:

Sub CreateWorksheetsByUniqueValues()
Dim ws As Worksheet
Dim lastRow As Long
Dim cell As Range
Dim uniqueValues As Collection
Dim value As Variant
Dim newWorksheet As Worksheet
Dim newRow As Long

' Set the worksheet to work with
Set ws = ActiveSheet

' Find the last row in column A
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row

' Create a collection to store unique values from column A
Set uniqueValues = New Collection

' Loop through each cell in column A and add unique values to the collection
On Error Resume Next
For Each cell In ws.Range("A1:A" & lastRow)
uniqueValues.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0

' Loop through each unique value and create a new worksheet
For Each value In uniqueValues
' Add a new worksheet to the workbook
Set newWorksheet = Worksheets.Add(After:=ws)

' Rename the new worksheet with the unique value
newWorksheet.Name = value

' Copy the entire header row to the new worksheet
ws.Rows(1).Copy newWorksheet.Rows(1)

' Initialize the target row for copying data
newRow = 2

' Loop through each row in column A and copy matching rows to the new worksheet
For Each cell In ws.Range("A1:A" & lastRow)
If cell.Value = value Then
' Copy the entire row to the new worksheet
ws.Rows(cell.Row).Copy newWorksheet.Rows(newRow)
newRow = newRow + 1
End If
Next cell
Next value
End Sub

 

[Trebor76]

Hi mkseto,

When you say...

but recently due to merger of various positions, the workbooks now contain as much as 500,000 rows

...do you know how many unique entries there are? While there's no stated limit on the number of sheets an Excel workbook can have I dare say there's just too many to produce for Excel to handle in this case.

Having multiple sheets with the same layout is rarely the way to go. I'd look at setting up a single tab with all the data (like a table in a database) and then use filters to produce the reports you need from that.

Hope that helps,

Robert

 

[mkseto]

Hi mkseto,

When you say...



...do you know how many unique entries there are? While there's no stated limit on the number of sheets an Excel workbook can have I dare say there's just too many to produce for Excel to handle in this case.

Having multiple sheets with the same layout is rarely the way to go. I'd look at setting up a single tab with all the data (like a table in a database) and then use filters to produce the reports you need from that.

Hope that helps,

Robert

Despite the number of rows could be as much as 500,000+, the unique values remains <12

 

[Alex Blakenburg]

You are using a collection. Does that mean you need to be able to run it on a Mac os ?

 

[mkseto]

You are using a collection. Does that mean you need to be able to run it on a Mac os ?

Actually, Win11

 

[Alex Blakenburg]

This will only work if you aren't trying to copy over formulas from the original sheet.
If that is the case give it a try.

Sub CreateWorksheetsByUniqueValues_dict()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim newWorksheet As Worksheet
    
    Dim rngSrc As Range
    Dim arrSrc As Variant, arrOut As Variant
    Dim i As Long, j As Long, iOutRow As Long, iCol As Long
    Dim dictUniq As Object, dictKey As String, dKey As Variant
    
    Application.ScreenUpdating = False
    
    ' Set the worksheet to work with
    Set ws = ActiveSheet
    
    ' Find the last row in column A
    With ws
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
        
        Set rngSrc = .Range(.Cells(2, "A"), .Cells(lastRow, lastCol))
        arrSrc = rngSrc.value
    End With
    
    ' Load details range into Dictionary
    Set dictUniq = CreateObject("Scripting.dictionary")
    dictUniq.CompareMode = vbTextCompare
    For i = 1 To UBound(arrSrc)
        dictKey = arrSrc(i, 1)
        If Not dictUniq.exists(dictKey) Then
            dictUniq(dictKey) = 1
        Else
            dictUniq(dictKey) = dictUniq(dictKey) + 1
        End If
    Next i
    
    ' Loop through each unique value and create a new worksheet
    For Each dKey In dictUniq.Keys
        ' Add a new worksheet to the workbook
        Set newWorksheet = Worksheets.Add(After:=ws)
        
        ' Rename the new worksheet with the unique value
        newWorksheet.Name = dKey
        
        ' Dimension output (filtered) array
        ReDim arrOut(1 To dictUniq(dKey), 1 To UBound(arrSrc, 2))
        
        ' Copy the entire header row to the new worksheet
        ws.Rows(1).Copy newWorksheet.Rows(1)
        
        ' Loop through each row in column A and copy matching rows to the new worksheet
        iOutRow = 0
        For j = 1 To UBound(arrSrc)
            If arrSrc(j, 1) = dKey Then
                ' Copy the entire row to the new worksheet
                iOutRow = iOutRow + 1
                For iCol = 1 To UBound(arrSrc, 2)
                    arrOut(iOutRow, iCol) = arrSrc(j, iCol)
                Next iCol
            End If
        Next j
        
        With newWorksheet.Range("A2").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
            .value = arrOut
            rngSrc.Rows(1).Copy
            .PasteSpecial Paste:=xlPasteFormats
            .EntireColumn.AutoFit
            newWorksheet.Range("A2").Select
            'Application.Goto newWorksheet.Range("A2")
        End With
    Next dKey
    Application.Goto ws.Range("A2")
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

 

[mkseto]

This will only work if you aren't trying to copy over formulas from the original sheet.
If that is the case give it a try.

Sub CreateWorksheetsByUniqueValues_dict()
    Dim ws As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim newWorksheet As Worksheet
   
    Dim rngSrc As Range
    Dim arrSrc As Variant, arrOut As Variant
    Dim i As Long, j As Long, iOutRow As Long, iCol As Long
    Dim dictUniq As Object, dictKey As String, dKey As Variant
   
    Application.ScreenUpdating = False
   
    ' Set the worksheet to work with
    Set ws = ActiveSheet
   
    ' Find the last row in column A
    With ws
        lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
        lastCol = ws.Cells(1, ws.Columns.Count).End(xlToLeft).Column
       
        Set rngSrc = .Range(.Cells(2, "A"), .Cells(lastRow, lastCol))
        arrSrc = rngSrc.value
    End With
   
    ' Load details range into Dictionary
    Set dictUniq = CreateObject("Scripting.dictionary")
    dictUniq.CompareMode = vbTextCompare
    For i = 1 To UBound(arrSrc)
        dictKey = arrSrc(i, 1)
        If Not dictUniq.exists(dictKey) Then
            dictUniq(dictKey) = 1
        Else
            dictUniq(dictKey) = dictUniq(dictKey) + 1
        End If
    Next i
   
    ' Loop through each unique value and create a new worksheet
    For Each dKey In dictUniq.Keys
        ' Add a new worksheet to the workbook
        Set newWorksheet = Worksheets.Add(After:=ws)
       
        ' Rename the new worksheet with the unique value
        newWorksheet.Name = dKey
       
        ' Dimension output (filtered) array
        ReDim arrOut(1 To dictUniq(dKey), 1 To UBound(arrSrc, 2))
       
        ' Copy the entire header row to the new worksheet
        ws.Rows(1).Copy newWorksheet.Rows(1)
       
        ' Loop through each row in column A and copy matching rows to the new worksheet
        iOutRow = 0
        For j = 1 To UBound(arrSrc)
            If arrSrc(j, 1) = dKey Then
                ' Copy the entire row to the new worksheet
                iOutRow = iOutRow + 1
                For iCol = 1 To UBound(arrSrc, 2)
                    arrOut(iOutRow, iCol) = arrSrc(j, iCol)
                Next iCol
            End If
        Next j
       
        With newWorksheet.Range("A2").Resize(UBound(arrOut, 1), UBound(arrOut, 2))
            .value = arrOut
            rngSrc.Rows(1).Copy
            .PasteSpecial Paste:=xlPasteFormats
            .EntireColumn.AutoFit
            newWorksheet.Range("A2").Select
            'Application.Goto newWorksheet.Range("A2")
        End With
    Next dKey
    Application.Goto ws.Range("A2")
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

No formula, so this works perfectly. Amazing how fast it completed the task, THANK YOU !!!!!!!

 

[Alex Blakenburg]

You're welcome. Thanks for the feedback and glad we could help.