CODEWITHSUNDEEP
excelvbafor-loop
Sean
Sean

Reputation: 21

VBA Loop Taking Forever - Where Can I Optimize?

I have written the below code in order to sum a specified column in a closed workbook.

The summary sheet I have has the file location/name in Column B, Sum Column Location in Column C, Conversion of Column Letter to Number in Column D, and then the Sum Amount in Column E.

I currently have about 50 workbooks that I need to pull the data from so I created a loop that first tests to see if a file exists (the file names change daily and are available at different times each day), if the file exists then it opens the workbook and sums the specified column for that workbook, puts that Sum in the summary sheet Column E and then closes the book and then moves to the next Row. It takes a while to run and since a lot of you are way better at coding than I am I was wondering if/how I could make this run more optimally. Any help is greatly appreciated.

Here is my current code:

Sub GetClosedPNL2()

    Application.ScreenUpdating = False

    Dim wbBook1 As Workbook: Set wbBook1 = ThisWorkbook
    Dim src As Workbook
    Dim lCol As Integer
    Dim LastRow As Long
    Dim DataRange As Range
    Dim Cll As Range
    Dim strFileName As String
    Dim strFileExists As String
       
    LastRow = Sheets("AccountMap").Cells(Sheets("AccountMap").Rows.Count, "B").End(xlUp).Row
    Set DataRange = Sheets("AccountMap").Range("B2:B" & LastRow)

    For Each Cll In DataRange
        strFileName = (Cll.Value)
        strFileExists = Dir(strFileName)
    
        If strFileExists = "" Then 
            GoTo Line2 
        Else 
            GoTo Line1
    
Line1:
        Set src = Workbooks.Open(Cll.Value, ReadOnly:=True)
        lCol = Cll.Offset(0, 2).Value
        Cll.Offset(0, 3) = Application.Sum(src.Sheets(1).Columns(lCol))
        src.Close False
        Set src = Nothing
    
Line2:
    Next Cll

End Sub

Upvotes: 2

Views: 135

Answers (1)

VBasic2008
VBasic2008

Reputation: 54787

Copy the Sum of a Column to Another Workbook

  • You know that Columns works also with strings? These are the same:

    Columns(1)
Columns("A")

  • Note that Application.Sum will raise an error if the cells contain error values.

  • Often it is a good idea to end your code with a message box to be notified that the code has finished. Put it after Application.ScreenUpdating = True, to immediately notice the changes in the background (worksheet), if any.

The Flow

  • Data is the array where the range in columns B:E is written to. Each file path in the array's (range's) first column is used to check if the file exists. If it does, it is opened, the required sum is written to the first column, and the file is closed. If it doesn't exist, the value from the fourth column is written to the first column. In both cases, the current file path is overwritten. Finally, only the first column is written to column E in the worksheet.

The Code (Not Tested)

Option Explicit

Sub GetClosedPNL2()

    Dim DataRange As Range
    Dim LastRow As Long
    With ThisWorkbook.Worksheets("AccountMap")
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
        Set DataRange = .Range("B2:B" & LastRow) ' "B"
    End With
    
    Dim Data As Variant: Data = DataRange.Resize(, 4).Value ' "B:E"
    
    Application.ScreenUpdating = False
    
    Dim FileName As String
    For i = 1 To UBound(Data, 1)
        FileName = Dir(Data(i, 1))
        If Len(FileName) > 0 Then
            Application.DisplayAlerts = False
            With Workbooks.Open(Data(i, 1), ReadOnly:=True)
                Data(i, 1) = Application.Sum(.Worksheets(1).Columns(Data(i, 3)))
                .Close SaveChanges:=False
            End With
            Application.DisplayAlerts = True
        Else
            Data(i, 1) = Data(i, 4)
        End If
    Next i
    
    ' Redim Preserve Data(1 To UBound(Data, 1), 1 to 1) ' Not nesessary.
    DataRange.Offset(, 3).Value = Data ' "E"
    
    Application.ScreenUpdating = True

    MsgBox "Sum column updatad.", vbInformation, "Success"

End Sub

Upvotes: 1

Related Questions