Macro works, but it's slow. How can I speed this up?

[marnold]

Hi,

I am using the VBA code below to pull out data from a ledger file. The macro breaks out the data in the ledger into new tabs based on what's in columns A, B, and C. Each line of data ends up on 3 different new tabs. The title of the new tabs is the unique data id found in columns A, B, and C. Column A houses the department numbers, so I have a ledger for each department once this macro runs. Column B houses my Leader names, so I have a ledger for each Leader once this macro runs. Column C houses my group names, so I have a ledger for each group once this macro runs. Though the line quantity varies depending on the day of the month, there is always data in columns A-BM. Some months I only have 30K lines of data, but other months I may have 100K lines of data. This rule takes between 30 minutes and 1.5 hours to run depending on the quantity of lines.

My question, how can I improve the run time here? The rule works great without error, but the run time is long, and it keeps me from being able to use my computer during the run time.

Side note, I have a separate macro that moves each tab into its own file, and then I have another macro that emails the ledger along with other attachments to a set of recipients. The tab names have to reflect what's in columns A thru C, or my other macros will fail.

Any help you can provide is greatly appreciated!

Sub Split_FIRST_Sheet_to_Tabs_Column_A_thru_C_Ref()
    Dim objWorksheet As Excel.Worksheet
    Dim nLastRow, nRow, nNextRow As Integer
    Dim strColumnValue As String
    Dim objDictionary As Object
    Dim varColumnValues As Variant
    Dim varColumnValue As Variant
    Dim objSheet As Excel.Worksheet
    
    Dim originalCalcMode As XlCalculation
    originalCalcMode = Application.Calculation
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range("A" & nRow).Value
        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If
    Next
    
    varColumnValues = objDictionary.Keys
    
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        objSheet.Name = varColumnValue
        objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range("A" & nRow).Value) = CStr(varColumnValue) Then
                objWorksheet.Rows(nRow).EntireRow.Copy
                nNextRow = objSheet.Range("A" & objSheet.Rows.Count).End(xlUp).Row + 1
                objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next
        objSheet.Columns("A:BM").AutoFit
        
    Sheets(1).Select

    Next
    
        Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("B" & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range("B" & nRow).Value
        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If
    Next
    
    varColumnValues = objDictionary.Keys
    
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        objSheet.Name = varColumnValue
        objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range("B" & nRow).Value) = CStr(varColumnValue) Then
                objWorksheet.Rows(nRow).EntireRow.Copy
                nNextRow = objSheet.Range("B" & objSheet.Rows.Count).End(xlUp).Row + 1
                objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next
        objSheet.Columns("A:BM").AutoFit
        
    Sheets(1).Select

            Next
    
        Set objWorksheet = ActiveSheet
    nLastRow = objWorksheet.Range("C" & objWorksheet.Rows.Count).End(xlUp).Row
    Set objDictionary = CreateObject("Scripting.Dictionary")
    
    For nRow = 2 To nLastRow
        strColumnValue = objWorksheet.Range("C" & nRow).Value
        If objDictionary.Exists(strColumnValue) = False Then
           objDictionary.Add strColumnValue, 1
        End If
    Next
    
    varColumnValues = objDictionary.Keys
    
    For i = LBound(varColumnValues) To UBound(varColumnValues)
        varColumnValue = varColumnValues(i)
        Set objSheet = Worksheets.Add(After:=Worksheets(Worksheets.Count))
        objSheet.Name = varColumnValue
        objWorksheet.Rows(1).EntireRow.Copy objSheet.Rows(1)
        For nRow = 2 To nLastRow
            If CStr(objWorksheet.Range("C" & nRow).Value) = CStr(varColumnValue) Then
                objWorksheet.Rows(nRow).EntireRow.Copy
                nNextRow = objSheet.Range("C" & objSheet.Rows.Count).End(xlUp).Row + 1
                objSheet.Range("A" & nNextRow).PasteSpecial xlPasteValuesAndNumberFormats
            End If
        Next
        objSheet.Columns("A:BM").AutoFit
      
       Sheets(1).Select
      
    Next
    
    Application.Calculation = originalCalcMode
    Application.ScreenUpdating = True
    
    Application.Speech.Speak "It Is Finished"
    MsgBox ("Macro finished successfully!")
      
End Sub

 

[Marc L]

Hi, an easy & faster way is to build the list of the unique data using an advanced filter - Excel basics ! - then from this list​

each unique worksheet can be created and directly filled again with an advanced filter​

which can at once filter & copy data with a single VBA codeline​

so far faster than looping / copying row by row like several times demonstrated within this forum ...​

​

Side note, I have a separate macro that moves each tab into its own file

Weird, why not creating directly the files (via an advanced filter) rather than creating tabs & moving them ?​

​

 

[marnold]

Thanks, I'll look into this. I'm needing the file with the tabs broken out for some processes while also needing the separate files for other processes. It's highly inefficient (not my choice), but I'm trying my best to find efficiencies where I can.

 

[Marc L]

Using an advanced filter to split data to worksheets will simplify your VBA procedure, needing less than 30 codelines so​

​

♪ do it, make it, move it : better, faster, stronger ♫ !​

​

​

My two cents according to the initial post's code :​

• objWorksheet.Rows(nRow).EntireRow.Copy : copying rows of 16 384 columns has poor sense as it seems only 65 columns are used
  so slowing more the already slow looping procedure ! Better is to use rows of CurrentRegion or UsedRange ...
  
  
• Sheets(1).Select is useless 'cause the below codeline Set objWorksheet = ActiveSheet is useless as well 'cause already defined at the beginning,
  this is the issue when copying down a specific column process code to manage another column without keeping the necessary only.
  As the 3 columns process parts can be only one within a column index loop ...