2
\$\begingroup\$

My apologies for a "repost", my original post was only partial and confusing. Here is a better snippet. This runs fairly slow (30 seconds or so) cycling through 20 workbooks. Any suggestions for improvement would be appreciated; I have left out my dimming of variables at the beginning, as well as my error handling portions, as those all work just fine.

For even MORE details, the user enters file paths into a column of up to 28 filepaths, and then the adjacent column derives the file name from the path. This macro, once initiated via a command button, begins cycling through all those filepaths, opening the document, copying and pasting it to the main workbook, until it reaches an empty cell in the column, to which then it stops.

There are also a few other small parts in there, like updating the last modified date when the button is clicked, as well as taking information from the first opened sheet to let the user know (on the main page) what kind of information is being pulled or has been pulled. Additionally, I often include frequent status bar updates for my impatient users who don't like staring at a spinning cursor without being told what's going on.

Private Sub CommandButton19_Click()

Application.DisplayStatusBar = True
Application.ScreenUpdating = False 'run faster
Application.DisplayAlerts = False 'prevents clipboard prompt
Application.Cursor = xlWait

On Error GoTo HandleIt

    Dim RangeDifferentiator As Integer
    Dim i As Long
    Dim SheettoCopyLoop
    Dim FileToCopyLoop
    Dim FileNameLoop

For i = 1 To 28 'start loop (28 because the last row being used is 34. If we need more rows this needs to change)

    RangeDifferentiator = i + 5
    Sheets("Admin").Select
    SheettoCopyLoop = Range("D" & RangeDifferentiator)
    FileToCopyLoop = Range("E" & RangeDifferentiator)
    FileNameLoop = Range("F" & RangeDifferentiator)

If FileToCopyLoop <> "" Then

    Application.StatusBar = "Pulling data for " & SheettoCopyLoop & "..." 'let's us know which one it's pulling
    Sheets(SheettoCopyLoop).Cells.ClearContents
    Workbooks.Open Filename:= _
        FileToCopyLoop
    'Needs optimizing
    Sheets("Summary").Cells.Copy

    'Establishes if this is a MTD or YTD file and up to what month it's pulling
    If i = 1 Then
        Workbooks("YTD File.xlsm").Sheets("SM Summaries").Range("C2").Value = ActiveWorkbook.Sheets("Summary").Range("C6").Value
        Workbooks("YTD File.xlsm").Sheets("SM Summaries").Range("C4").Value = ActiveWorkbook.Sheets("Summary").Range("C5").Value
    End If

    'Needs optimizing
    Windows("YTD File.xlsm").Activate
    Sheets(SheettoCopyLoop).Select
    Sheets(SheettoCopyLoop).Range("A1").Select
    ActiveSheet.Paste
    ActiveSheet.Range("A1").Select
    Windows(FileNameLoop).Close
    Sheets("Admin").Select
    Range("A1").Select

Else
Application.StatusBar = "READY"
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Cursor = xlDefault
'Show last modified date on admin page for the user
Workbooks("YTD File.xlsm").Sheets("Admin").Range("F1").Value = "Last modified: " & Date
MsgBox "Data pull complete!", vbInformation, "Success!"
Exit Sub
End If

Next i
Exit Sub

'The following is all error handling to help show what went wrong and where
HandleIt:
If SheettoCopyLoop <> "" Then
errorhandler = MsgBox("Oops! An error has occured on page " & SheettoCopyLoop & ". Check to make sure file exists/file path is correct.", vbExclamation, "Error!")
Application.StatusBar = "Error occured on page " & SheettoCopyLoop 'Show where error occured on status bar if applicable
Else
errorhandler = MsgBox("Oops! An unknown error has occured.", vbCritical, "Error!")
Application.StatusBar = "Unknown error"
End If
Worksheets("Admin").Activate
Range("H7").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Exit Sub
End Sub
\$\endgroup\$
1
\$\begingroup\$

I'm not sure why it takes 30 seconds to process the 20 files, because with my almost empty test files, your code only takes 2.202 seconds (21 files). I'm guessing those files are quite large, contain a lot of objects, charts, data (?)

If they have a lot of rows I'd suggest changing them to the xlsb format, which will compress them quite a bit (size could go down to 40%), and they will be a lot faster to open and close

XLSB Format

XLSB is the Excel binary format. It is structured as a compressed folder that contains a large number of binary files. It is much more compact than the XLS format, but the amount of compression very much depends on the contents of the workbook. For example, ten workbooks show a size reduction factor ranging from two to eight with an average reduction factor of four...

Another consideration is that interacting with files over the network is considerably slower than the local drive


Related to the code, there are a few basic issues:


  • To properly replace the select statements you need to refer to all objects explicitly:

Example - instead of

Windows("YTD File.xlsm").Activate
Sheets(SheettoCopyLoop).Select
Sheets(SheettoCopyLoop).Range("A1").Select
ActiveSheet.Paste

use:

Windows("YTD File.xlsm").Sheets(SheettoCopyLoop).Range("A1").Paste

  • Indent your code to make it easier to read, and distinguish hierarchies of logic and nesting
  • It's better to prevent all errors than to rely on the "On Error GoTo" statements
    • There are few errors that cannot be avoided
    • The GoTo statement breaks the flow and structure of the code
  • Turn off Application.Calculation (to manual) if possible
  • Don't force the user to dismiss dialog boxes after every iteration
    • They only need to be aware if their task cannot be completed

I made some changes, such as copying the entire sheets to the main Workbook, instead of copying only the data, so here is how I would change your code:


Option Explicit

Private Sub CommandButton19_Click2()
    Dim wb As Workbook, ws As Worksheet, newWB As Workbook
    Dim wsSMS As Worksheet, wsS As Worksheet, wsNew As Worksheet
    Dim fileInfo As Variant, sheetToCopy As String, r As Long
    Dim fileToCopy As String, fileName As String, t As Double

    t = Timer

    OptimizeXl True, xlWait

    Set wb = ThisWorkbook
    Set ws = wb.Worksheets("Admin")
    Set wsSMS = wb.Worksheets("SM Summaries")

    fileInfo = ws.Range("D6:F34").Value2

    For r = 1 To UBound(fileInfo)               'max xl sheet name length = 31 chars
        sheetToCopy = Left(fileInfo(r, 1), 31)  'column 1 of Range("D6:F34") (Col D)
        fileToCopy = fileInfo(r, 2)             'column 2 of Range("D6:F34") (Col E)
        fileName = fileInfo(r, 3)               'column 3 of Range("D6:F34") (Col F)

        'Continue only if all necessary file details are not empty
        If Len(fileToCopy) > 0 And Len(sheetToCopy) > 0 And Len(fileName) > 0 Then
            If Len(Dir(fileToCopy)) > 0 Then    'continue only if file exists
                Application.StatusBar = "Pulling data for " & fileName & "..."

                Set newWB = Workbooks.Open(fileToCopy, False, True) 'NoLinks, ReadOnly

                If WsExists(newWB, "Summary") Then
                    'Delete existing sheet named "sheetToCopy"
                    If WsExists(wb, sheetToCopy) Then wb.Worksheets(sheetToCopy).Delete
                    Set wsS = newWB.Worksheets("Summary")
                    If r = 1 Then
                        wsSMS.Range("C2").Value = wsS.Range("C6").Value
                        wsSMS.Range("C4").Value = wsS.Range("C5").Value
                    End If
                    'Copy new sheet into this workbook, and rename it to "sheetToCopy"
                    wsS.Copy After:=wb.Worksheets(wb.Worksheets.Count)
                    Set wsNew = wb.Worksheets(wb.Worksheets.Count)
                    wsNew.Name = sheetToCopy
                Else
                    Debug.Print "Invalid sheet name for file on row " & r
                End If
                newWB.Close False
            Else
                Debug.Print "Invalid fileToCopy on row " & r & " (" & fileToCopy & ")"
            End If
            ws.Range("F1").Value2 = "Last modified: " & Date
        Else
            Debug.Print "Empty fileToCopy, sheetToCopy, or fileName on row " & r
        End If
    Next
    ws.Activate
    OptimizeXl False
    Application.StatusBar = "READY"
    Debug.Print "V2 Time: " & Format(Timer - t, "0.000") & " sec"
    MsgBox "Data pull complete!", vbInformation, "Success!"
End Sub

Private Sub OptimizeXl(ByVal stat As Boolean, Optional ByVal curs As Long = xlDefault)
    Application.Calculation = IIf(stat, xlCalculationManual, xlCalculationAutomatic)
    Application.ScreenUpdating = Not stat
    Application.DisplayAlerts = Not stat
    Application.Cursor = curs
End Sub

Private Function WsExists(ByRef wb As Workbook, ByVal wsName As String) As Boolean
    Dim ws As Worksheet
    If Not wb Is Nothing Then
        If Len(wsName) > 0 Then
            For Each ws In wb.Worksheets
                If ws.Name = wsName Then
                    WsExists = True
                    Exit Function
                End If
            Next
        End If
    End If
End Function

Test results:

V1 Time: 2.202 sec (your code)
V2 Time: 1.012 sec
\$\endgroup\$
  • \$\begingroup\$ Was just able to view this now, very helpful, thank you very much! I had actually started using Option Explicit about a month ago, I didn't include it here... Wish I had known more about that when I was writing hundreds of pages in Word VBA and running into errors all the time... One thing I must say, though, is I'm very adamant about keeping in dialog boxes for after all interactions. Why? Because my users aren't always tech savvy, and if they click a button and aren't told what happened, they might think it just doesn't work and try clicking it again. I keep those there for guidance. \$\endgroup\$ – dwirony Jul 26 '17 at 15:01

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

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