split macro to run faster

[sachin483]

i have macro for splitting excel sheets depending on column A for all the sheets , i have 20000 rows and 35 sheets to split in a workbook , it take around 1 to 2 hours for splitting, can it be faster

Sub SplitData()
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim r As Long
    Dim m As Long
    Dim col As New Collection
    Dim v As Variant
    Dim s As String
    On Error Resume Next
    For Each wsh In ThisWorkbook.Worksheets
        m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        For r = 4 To m
            col.Add Item:=wsh.Range("A" & r).Value, Key:=wsh.Range("A" & r).Value
        Next r
    Next wsh
    On Error GoTo 0
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each v In col
        ThisWorkbook.Worksheets.Copy
        Set wbk = ActiveWorkbook
        For Each wsh In wbk.Worksheets
            m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
            For r = m To 4 Step -1
                If wsh.Range("A" & r).Value <> v Then
                    wsh.Range("A" & r).EntireRow.Delete
                End If
                Next r
                If wsh.Range("A4").Value = "" Then wsh.Delete
            Next wsh
             s = ThisWorkbook.Path & "\" & v & ".xlsx"
               wbk.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook
        wbk.Close
    Next v
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
End Sub

 

[Dryver14]

Is it possible to do a find for v if the result comes back as nil then delete the sheet before running alll the steps?

 

[sachin483]

The result in the first sheet will not be nil but in others sheets can be nil so it finding and matching the data and then deleting the rest

 

[dk]

Maybe try turning calculation to manual:

    Dim lCalcMode As Long

    lCalcMode = Application.Calculation
    
    Application.Calculation = xlCalculationManual
    
    '
    '  main code here
    '
    
    
    Application.Calculation = lCalcMode

 

[Dryver14]

If wsh.Range("A4").Value = "" Then wsh.Delete

It was this line that made me suggest my point as you seem to loop through everything then delete the sheet if everything has been deleted one line at a time.

How many sheets and rows are there 2 hours does seem a long time
​

 

[sachin483]

If wsh.Range("A4").Value = "" Then wsh.Delete-- the data is like

AA
AA
AA
AB
AB
AC
AC
AC

so it has to delete the rest and there is 20000 rows and 20 sheets

 

[sachin483]

@dk error at Application ------

Invalid outside procedure

 

[dk]

@dk error at Application ------

Invalid outside procedure

Did you include the code I mentioned in your existing procedure? It should look something like this:

Sub SplitData()
    Dim wbk As Workbook
    Dim wsh As Worksheet
    Dim r As Long
    Dim m As Long
    Dim col As New Collection
    Dim v As Variant
    Dim s As String
    
    Dim lCalcMode As Long
    
    
    lCalcMode = Application.Calculation
    
    Application.Calculation = xlCalculationManual
    
    On Error Resume Next
    For Each wsh In ThisWorkbook.Worksheets
        m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        For r = 4 To m
            col.Add Item:=wsh.Range("A" & r).Value, Key:=wsh.Range("A" & r).Value
        Next r
    Next wsh
    On Error GoTo 0
    Application.Cursor = xlWait
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    For Each v In col
        ThisWorkbook.Worksheets.Copy
        Set wbk = ActiveWorkbook
        For Each wsh In wbk.Worksheets
            m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
            For r = m To 4 Step -1
                If wsh.Range("A" & r).Value <> v Then
                    wsh.Range("A" & r).EntireRow.Delete
                End If
                Next r
                If wsh.Range("A4").Value = "" Then wsh.Delete
            Next wsh
             s = ThisWorkbook.Path & "\" & v & ".xlsx"
               wbk.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook
        wbk.Close
    Next v
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.Cursor = xlDefault
    Application.Calculation = lCalcMode
    
    
    
End Sub

 

[dk]

Here is some slightly modified code that should be quicker. It uses a range variable to store which rows should be deleted then deletes them all at once rather than individually:

Sub SplitData()
Dim wbk As Workbook
Dim wsh As Worksheet
Dim r As Long
Dim m As Long
Dim col As New Collection
Dim v As Variant
Dim s As String

Dim lCalcMode As Long


lCalcMode = Application.Calculation

Application.Calculation = xlCalculationManual

On Error Resume Next
For Each wsh In ThisWorkbook.Worksheets
    m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
    For r = 4 To m
        col.Add Item:=wsh.Range("A" & r).Value, Key:=wsh.Range("A" & r).Value
    Next r
Next wsh
On Error GoTo 0
Application.Cursor = xlWait
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Dim rngDelete As Range

For Each v In col
    ThisWorkbook.Worksheets.Copy
    Set wbk = ActiveWorkbook
    For Each wsh In wbk.Worksheets
        m = wsh.Range("A" & wsh.Rows.Count).End(xlUp).Row
        For r = m To 4 Step -1
            If wsh.Range("A" & r).Value <> v Then
                
                If rngDelete Is Nothing Then
                    Set rngDelete = wsh.Range("A" & r)
                Else
                    Set rngDelete = Union(rngDelete, wsh.Range("A" & r))
                End If
            
                    'replaced by single delete operation after loop
'                wsh.Range("A" & r).EntireRow.Delete
            End If
        Next r
        
        rngDelete.EntireRow.Delete
        Set rngDelete = Nothing
        
        
        If wsh.Range("A4").Value = "" Then wsh.Delete
    Next wsh
    s = ThisWorkbook.Path & "\" & v & ".xlsx"
    wbk.SaveAs Filename:=s, FileFormat:=xlOpenXMLWorkbook
    wbk.Close
Next v
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Application.Calculation = lCalcMode



End Sub

 

[sachin483]

@dk thanks a lot working fine as i have one more macro which i was testing is working fast but formatting changes can you guide me to modify

Sub test()
    Dim ws As Worksheet, wb As Workbook
    Dim a, e, i As Long, ii As Long, w, x
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For Each ws In Worksheets
            a = ws.UsedRange.Value
            ReDim w(1 To UBound(a, 2))
            For i = 4 To UBound(a, 1)
                If a(i, 1) = "" Then Exit For
                If Not .exists(a(i, 1)) Then
                    Set .Item(a(i, 1)) = CreateObject("Scripting.Dictionary")
                End If
                If Not .Item(a(i, 1)).exists(ws.Name) Then
                    ReDim x(1 To 2)
                    Set x(1) = CreateObject("System.Collections.ArrayList")
                    Set x(2) = ws.UsedRange.Rows("1:3")
                    .Item(a(i, 1))(ws.Name) = x
                End If
                For ii = 1 To UBound(a, 2)
                    w(ii) = a(i, ii)
                Next
                .Item(a(i, 1))(ws.Name)(1).Add w
            Next
        Next
        For Each e In .keys
            Set wb = Workbooks.Add
            For i = 0 To .Item(e).Count - 1
                If i + 1 > wb.Sheets.Count Then
                    wb.Sheets.Add after:=wb.Sheets(wb.Sheets.Count)
                    wb.Sheets(wb.Sheets.Count).Name = .Item(e).keys()(i)
                Else
                    wb.Sheets(i + 1).Name = .Item(e).keys()(i)
                End If
                w = Application.Index(.Item(e).items()(i)(1).ToArray, 0, 0)
                .Item(e).items()(i)(2).Copy wb.Sheets(.Item(e).keys()(i)).Cells(1)
                wb.Sheets(.Item(e).keys()(i)).[a4] _
                .Resize(UBound(w, 1), UBound(w, 2)).Value = w
            Next
            wb.SaveAs ThisWorkbook.Path & "\" & e & ".xlsx"
            wb.Close
        Next
    End With
End Sub