Very Slow Macro, faster without it?

Question

I found this forum while searching for an answer to my problem. I found the solution posted here:

How do I save each sheet in an Excel 2010 workbook to separate CSV files with a macro?

I appologize for not commenting on that post, but I could not find an option to do so. So, I am posting this question.

I am not using the zip function, just creating the CSV files and excluding some of the sheets. As you can see, I am also doing some find/replace functions and refreshing data.

It is working fine with the exception it is taking a very long time to run (1-1/2 hours). If I remove the save functions, and save each sheet manually, it can be completed in a few minutes.

What is bogging it down?

Code below (sorry for the poor formatting)

Sub Worksheet_Macro()
' Category_Trail Macro
' Macro breaks category trail down into individual categories. TO BE USED ONLY IN THE "WORKSHEET" SHEET
'

'

 Dim ws As Worksheet
 Dim strMain As String
 Dim lngCalc As Long

 strMain = "C:\Users\David Cox\Documents\TotalOutdoorsman\Site\Inventory\Daily Upload Files\"


' Turn off calculations
 With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
 End With

'Update all Data

    ActiveWorkbook.RefreshAll

'Copy and Paste Categories and create trail

    Sheets("Worksheet").Select
    Range("Ah2:Ah20000").Select
    Selection.Copy
    Range("Ai2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("Ai2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True


' Clean_Description Macro
' Macro copies and pastes product descriptions to new column and then cleans them of HTML code.
'
'
    Range("AO2:AO20000").Select
    Selection.Copy
    Range("AP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("AP:AP").Select
    Selection.Replace What:="<br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="</br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Remove Appostrophies Macro
    Sheets("RSR Inventory").Select
    Columns("L:L").Select
    Range("L5743").Activate
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets("Valor Inventory").Select
    ActiveWindow.LargeScroll ToRight:=-1
    Columns("C:C").Select
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Go back to Main Product Page
    Sheets("MainProductPage").Select

'Turn Calculations back on
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = lngCalc
End With

'Save before creating CSV Files
ThisWorkbook.Save

' Turn off calculations
 With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    lngCalc = .Calculation
    .Calculation = xlCalculationManual
 End With

'Save all CSV files
For Each ws In ActiveWorkbook.Worksheets
    Select Case ws.Name
    Case "Imported Product Data", "Sheet 2", "Sheet 3"
    'do nothing for these sheets
    Case Else
    ws.SaveAs strMain & ws.Name, xlCSV
    End Select
Next

'Turn Calculations back on
 With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .Calculation = lngCalc
 End With

End Sub

@KenWhite, it seems to me the question was very explicit - this code is slow as is, and speeds up tremendously when the save functions are removed (`ThisWorkbook.save` and `ws.SaveAs`) and the results are saved by hand. — Mark Ransom, Jun 18 '12 at 22:54
@MarkRansom, seems I read it incorrectly. Deleting my comment - thanks. — Ken White, Jun 18 '12 at 22:56
Moved from answer to a comment. Why are you turning calculations and screen updates back on just before saving? Also - along with screen updating - can you turn off events? And turn them back on when you are done. (Application.EnableEvents = False) — quixver, Jun 18 '12 at 23:02
This is where my lack of programming knowledge is causing a problem. I copied the code from the post I referenced and pasted it in mine that I created with the "recorder". Ideally, the process will turn calculations off to reduce run time, refresh all data, and run the find/replace functions. Then it will turn the calcs back on to calculate prices, inventory levels, etc based on the new data. Save the file as an xls file. At that point, the data will not change again, so I turn off the calculations, again to speed it up, and save several CSV files that will get uploaded to various sites. — David Cox, Jun 19 '12 at 02:33

score 1 · Answer 1 · answered Jun 19 '12 at 03:58

Try this code (Untested)

I have

Removed lot of unnecessary code like .Select, .LargeScroll and events which were making your macro slow.
I have introduced Error Handling, which is a must when you are adjusting Application Settings

Give it a try and let me know if there is any difference now.

Sub Worksheet_Macro()
    Dim ws As Worksheet
    Dim strMain As String
    Dim lngCalc As Long

    On Error GoTo Whoa

    strMain = "C:\Users\David Cox\Documents\TotalOutdoorsman\Site\Inventory\Daily Upload Files\"

    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End With

    With Sheets("Worksheet")
        .Range("AH2:AH20000").Copy
        With .Range("AI2")
            .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

            .TextToColumns Destination:=.Range("AI2"), DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
            Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
            :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
            TrailingMinusNumbers:=True
        End With

        .Range("AO2:AO20000").Copy

        .Range("AP2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

        With .Columns("AP:AP")
            .Replace What:="<br>", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False

            .Replace What:="</br>", Replacement:="", LookAt:=xlPart, _
            SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
            ReplaceFormat:=False
        End With
     End With

    With Sheets("RSR Inventory")
        .Columns("L:L").Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End With

    With Sheets("Valor Inventory")
        .Columns("C:C").Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    End With

    '~~> Save before creating CSV Files
    ThisWorkbook.Save

    '~~> Save all CSV files
    For Each ws In ThisWorkbook.Worksheets
        Select Case ws.Name
        Case "Imported Product Data", "Sheet 2", "Sheet 3"
            'do nothing for these sheets
        Case Else
            ws.SaveAs strMain & ws.Name, xlCSV
        End Select
    Next
LetsContinue:
     '~~> Reset Settings
     With Application
        .DisplayAlerts = True
        .ScreenUpdating = True
        .Calculation = lngCalc
        .CutCopyMode = False
     End With

     MsgBox "Done"
     Exit Sub
Whoa:
    MsgBox Err.Description
    Resume LetsContinue
End Sub

Siddharth, Thank you for the code! It did speed it up slightly, but since the calculations were turned off, the output was not correct. Upon playing some more, I realize that saving as a CSV is significantly faster if I have a separate file with links to my primary worksheet. This is of course doing it manually, I assume the same trend would follow with a macro. Is it possible to make the macro control multiple workbooks (files)? — David Cox, Jun 22 '12 at 15:26

score 0 · Answer 2 · answered Jun 25 '12 at 13:45

I got it! I decided to have separate Excel files for each CSV. It saves them a lot faster that way. Total run time is now in the 6 minute range!!! Here is what I ended up with:

Sub Worksheet_Macro()
' Category_Trail Macro
' Macro breaks category trail down into individual categories. TO BE USED ONLY IN THE "WORKSHEET" SHEET
'

'
Dim counter As Integer 'declare variable
Dim fname As String
Dim fname1 As String
Dim fileext As String
Dim csvfname As String
Dim directory As String

directory = "C:\Files\"


' Turn off visual feedback to speed up process
 With Application
    .DisplayAlerts = False
    .ScreenUpdating = False

 End With

'Update all Data

    ActiveWorkbook.RefreshAll

    Sheets("Worksheet").Select
    Range("Ah2:Ah15000").Select
    Selection.Copy
    Range("Ai2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Selection.TextToColumns Destination:=Range("Ai2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :="/", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True


' Clean_Description Macro
' Macro copies and pastes product descriptions to new column and then cleans them of HTML code.
'
'
    Range("AO2:AO15000").Select
    Selection.Copy
    Range("AP2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Columns("AP:AP").Select
    Selection.Replace What:="<br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Selection.Replace What:="</br>", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Remove Appostrophies Macro
    Sheets("RSR Inventory").Select
    Columns("L:L").Select
    Range("L5743").Activate
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    Sheets("Valor Inventory").Select
    ActiveWindow.LargeScroll ToRight:=-1
    Columns("C:C").Select
    Selection.Replace What:="'", Replacement:="", LookAt:=xlPart, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False

' Go back to Main Product Page
    Sheets("MainProductPage").Select



'Save all files


counter = 2 'initialize variable
Sheets("Save As Info").Select
Range("a2").Select '1st cell with file name

Do Until ActiveCell = "" 
    fname1 = Cells(counter, 1) 
    'this is set for column A
    filext = Cells(counter, 2) 
    fname = directory & fname1 & fileext 
    csvfname = directory & fname1 & "CSV.csv" 
    Workbooks.Open Filename:=fname 



    ActiveWorkbook.SaveAs Filename:=csvfname, FileFormat:=xlCSV, CreateBackup:=False
    'save as csv

    ActiveWorkbook.Close SaveChanges:=False 'close csv


    Windows("UpdateWorkbook.xlsm").Activate 'select workbook with file info
    Sheets("Save As Info").Select 'select sheet with file info

    counter = counter + 1
    ActiveCell.Offset(1, 0).Range("a1").Select 'This moves down the column


Loop

'Turn on visual feedback
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True

End With

    ActiveWorkbook.Close SaveChanges:=False 'close Excel File

End Sub

Very Slow Macro, faster without it?

2 Answers2