1
\$\begingroup\$

I have a longer Macro has sub functions opening many different Workbooks, takes the data, and pastes into a Destination Workbook through arrays and .value. There are also a few functions to bring over title and data value information.

However, the macro seems to get stuck for a few seconds every time a source Workbook is opened.
Would you please review the code to see if it can be any more efficient?

Option Explicit
Public Const TemplatePath As String = "C:\Users\cday\OneDrive - udfinc.com\M6 Scorecard\Data Pulls\"
Dim WbKrogerScorecard As Workbook
Dim SourceWBPath As String
Dim Data As Variant

Sub M6Scorecard_DataPaste()

    'Turn Off Screen Updates
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
        Set WbKrogerScorecard = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm")

        WeeklyDivision_DataPaste
        
        Combine_DataPaste

        StoreSelling_DataPaste

    'Save File as Template File
    ActiveWorkbook.Save
        
    'Turn on Screen Updates
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic
    
End Sub

Sub WeeklyDivision_DataPaste()

    Set WbKrogerScorecard = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm")
    
    Dim WsWeeklyDiv As Worksheet
    Set WsWeeklyDiv = WbKrogerScorecard.Worksheets("Weekly Division")
    
    With WsWeeklyDiv
        .Range("A15:W" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row).ClearContents
    End With
    
        SourceWBPath = TemplatePath & "Weekly Data.csv"

    With Workbooks.Open(SourceWBPath)
        With .Worksheets("Weekly Data")
            Dim Data(3) As Variant
            'Title Information
            Data(0) = .Range("A1:A12").Value
            
            'Data Cells
            Data(1) = .Range(.Cells(.Rows.Count, "A").End(xlUp), "I17").Value
            Data(2) = .Range("J17:N17").Resize(UBound(Data(1))).Value
            Data(3) = .Range("O17:P17").Resize(UBound(Data(1))).Value
        
        End With
        
        .Close SaveChanges:=False
    End With
    
    With WsWeeklyDiv
        'Move Title Information from "Weekly Data.csv" to WbKrogerScorecard.Worksheets("Weekly Division").Range("A1:A12")
        .Range("A1:A12").Value = Data(0)

        'Move Data Cells from "Weekly Data.csv" to WbKrogerScorecard.Worksheets("Weekly Division")
            'Cells "A17:I17"
            With .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Resize(UBound(Data(1)))
                .Resize(ColumnSize:=UBound(Data(1), 2)).Value = Data(1)
            End With
            'Cells L15:P15
            .Cells(.Rows.Count, "L").End(xlUp).Offset(1).Resize(UBound(Data(2)), UBound(Data(2), 2)).Value = Data(2)
            'Cells V15:W15
            .Cells(.Rows.Count, "V").End(xlUp).Offset(1).Resize(UBound(Data(3)), UBound(Data(3), 2)).Value = Data(3)
            
    End With
    
End Sub

Sub Combine_DataPaste()
    
    Dim WsCombined As Worksheet
    Set WsCombined = WbKrogerScorecard.Worksheets("COMBINED")
    
    With WsCombined
        .Range("A5:U" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row).ClearContents
    End With
    
    CombineWorksheets WbKrogerScorecard, "52 Wk Data.csv", 52
    CombineWorksheets WbKrogerScorecard, "26 Wk Data.csv", 26
    CombineWorksheets WbKrogerScorecard, "13 Wk Data.csv", 13
    CombineWorksheets WbKrogerScorecard, "4 Wk Data.csv", 4
    CombineWorksheets WbKrogerScorecard, "YTD Data.csv", 0
    
End Sub

Private Sub CombineWorksheets(WbKrogerScorecard As Workbook, FileName As String, FileIndex As Long)
    
    SourceWBPath = TemplatePath & FileName

    Data = GetCombineData(SourceWBPath)
    
    With WbKrogerScorecard
        Dim DateValue As String
        With WbKrogerScorecard.Worksheets("Weekly Division")
            If FileIndex = 0 Then
                DateValue = "Kroger YTD - Ending " & Left(Right(.Range("A4"), 24), 23)
            Else
                DateValue = "Latest " & FileIndex & " Wks - Ending " & Left(Right(.Range("A4"), 24), 23)
            End If
        End With
        
        With WbKrogerScorecard.Worksheets("COMBINED")

            With .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(UBound(Data(0)))
                .Offset(0, -1).Value = DateValue
                .Resize(ColumnSize:=UBound(Data(0), 2)).Value = Data(0)
            End With
            .Cells(.Rows.Count, "L").End(xlUp).Offset(1).Resize(UBound(Data(1)), UBound(Data(1), 2)).Value = Data(1)
        End With
    End With
    
End Sub

Private Function GetCombineData(SourceWBPath As String)

    With Workbooks.Open(SourceWBPath)
        With .Worksheets(1)
            Dim Data(1) As Variant
            Data(0) = .Range(.Cells(.Rows.Count, "A").End(xlUp), "H18").Value
            Data(1) = .Range("I18:R18").Resize(UBound(Data(0))).Value
        End With
         
        .Close SaveChanges:=False
    End With
    GetCombineData = Data
End Function


Sub StoreSelling_DataPaste()

    Set WbKrogerScorecard = Workbooks("KROGER M6 SCORECARD TEMPLATE.xlsm")
    
    Dim WsStoreSelling As Worksheet
    Set WsStoreSelling = WbKrogerScorecard.Worksheets("Stores Selling Summary")
    
    With WsStoreSelling
        .Range("A6:N" & .Cells(.Rows.Count, "A").End(xlUp).Offset(1).Row).ClearContents
    End With
    
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 52Wks_Frozen.csv", 52
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 52Wks_Natural.csv", 52
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 26Wks_Frozen.csv", 26
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 26Wks_Natural.csv", 26
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 13Wks_Frozen.csv", 13
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 13Wks_Natural.csv", 13
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 4Wks_Frozen.csv", 4
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling 4Wks_Natural.csv", 4
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling YTD_Frozen.csv", 0
    StoreSellingWorksheets WbKrogerScorecard, "Stores Selling YTD_Natural.csv", 0
    
End Sub

Private Sub StoreSellingWorksheets(WbKrogerScorecard As Workbook, FileName As String, FileIndex As Long)

    SourceWBPath = TemplatePath & FileName

    Data = GetStoreSellingData(SourceWBPath)
        
    With WbKrogerScorecard
        Dim DateValue As String
            
        With WbKrogerScorecard.Worksheets("Weekly Division")
            If FileIndex = 0 Then
                DateValue = "Kroger YTD - Ending " & Left(Right(.Range("A4"), 24), 23)
            Else
                DateValue = "Latest " & FileIndex & " Wks - Ending " & Left(Right(.Range("A4"), 24), 23)
            End If
        End With
        
        With WbKrogerScorecard.Worksheets("Stores Selling Summary")
            With .Cells(.Rows.Count, "B").End(xlUp).Offset(1).Resize(UBound(Data(0)))
                .Offset(0, -1).Value = DateValue
                .Resize(ColumnSize:=UBound(Data(0), 2)).Value = Data(0)
            End With
            .Cells(.Rows.Count, "G").End(xlUp).Offset(1).Resize(UBound(Data(1)), UBound(Data(1), 2)).Value = Data(1)
            .Cells(.Rows.Count, "I").End(xlUp).Offset(1).Resize(UBound(Data(2)), UBound(Data(2), 2)).Value = Data(2)
            .Cells(.Rows.Count, "M").End(xlUp).Offset(1).Resize(UBound(Data(3)), UBound(Data(3), 2)).Value = Data(3)
        End With
            
        UpdateStoresSellingSummaryAttributes
            
    End With
    
End Sub

Private Function GetStoreSellingData(SourceWBPath As String)
    
    With Workbooks.Open(SourceWBPath)
        With .Worksheets(1)
            Dim Data(3) As Variant
            Data(0) = .Range(.Cells(.Rows.Count, "A").End(xlUp), "B13").Value
            Data(1) = .Range("C13").Resize(UBound(Data(0))).Value
            Data(2) = .Range("F13:I13").Resize(UBound(Data(0))).Value
            Data(3) = .Range("D13:E13").Resize(UBound(Data(0))).Value
        End With
         
        .Close SaveChanges:=False
    End With
    
    GetStoreSellingData = Data
    
End Function

Private Sub UpdateStoresSellingSummaryAttributes()

    Const Formula As String = "=INDEX(COMBINED!$C:$F,MATCH($C6,COMBINED!$H:$H,0),MATCH(D$5,COMBINED!$C$4:$F$4,0))"
    Dim Target As Range
        
    With WbKrogerScorecard.Worksheets("Stores Selling Summary")
        Set Target = .Range("A6", .Range("A" & .Rows.Count).End(xlUp))
        Set Target = Target.Offset(, 3)
        Set Target = Target.Resize(, 3)
        Target.Formula = Formula
    End With

End Sub
\$\endgroup\$
3
  • 2
    \$\begingroup\$ "Is this normal?" probably. To be clear do you want a review of your code - do you want people to explain how you can make your code better? \$\endgroup\$
    – Peilonrayz
    Aug 28 '20 at 15:27
  • 1
    \$\begingroup\$ In programming, input/output (I/O) work is the slowest thing that can be done; opening a file from disk or network is I/O work, and while VBA is waiting for the Workbooks.Open function to return, it cannot do anything other than wait for the I/O to complete. So yes, this is normal. Please edit your post to clarify what reviewers are looking at? \$\endgroup\$ Aug 28 '20 at 17:54
  • \$\begingroup\$ @Peilonrayz - Yes, sorry I updated my post. Is there a way to make the code better or more efficient? \$\endgroup\$
    – CDay
    Aug 28 '20 at 18:12

Your Answer

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

Browse other questions tagged or ask your own question.