Help To Make Macro More Efficient/Speed Up - Copy/Paste & Drop Down List

[The Gent]

Hi guys,

I have the below macro that I am trying to speed up.

I have a table which pulls data from an Access DB, the data in the table changes upon selection of an item from a drop down list. The table needs to calculate upon each data 'refresh' in order to calculate some KPI's which I copy into another workbook.

This action is repeated to a total of 271 times. At the moment it is taking 2.5 hours to complete. I am hoping to decrease this time.

My concerns are around the drop down list/cycle item element, I don't think I have done this part too well as I have combined a few different sources to create it.

Sub SOFPChecksV2()
   Dim Eccwbk As Workbook
   Dim SOFPws As Worksheet, Trgws As Worksheet
   Dim i As Long
   Dim Res As Variant
  
   Set Eccwbk = Workbooks("VTO3 Rec Model - Live.xlsm")
   Set SOFPws = Eccwbk.Sheets("SOFP")
   Set Trgws = Workbooks("Reconciliation 3 Progress Tracker - Live.xlsx").Sheets("2020")
  
   Application.ScreenUpdating = False
   For i = 1 To 271
      Trgws.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("G1:G4").Value)
      Trgws.Range("G" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("H1:H4").Value)
      Trgws.Range("L" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("I1:I4").Value)
      With SOFPws.Range("B4")
         If .Value = "" Then
            .Value = Eccwbk.Sheets("Locations").Range("A2").Value
         Else
            Res = Application.Match(.Value, Eccwbk.Sheets("Locations").Range("A2:A272"), 0)
            If IsNumeric(Res) Then
               .Value = Eccwbk.Sheets("Locations").Range("A2:A272").Cells(Res + 1, 1).Value
            Else
               .Value = ""
            End If
         End If
      End With
      Eccwbk.RefreshAll
   Next i
End Sub

 

[DanteAmor]

I guess the main problem is the book update. But try the folllowing.
I removed the search you had within the For.
I put all the locations in an array, each change in the For counter will put a location in cell B4, update the book and copy the data.
Try and tell me.

Sub SOFPChecksV3()
  Dim Eccwbk As Workbook, SOFPws As Worksheet, Trgws As Worksheet
  Dim i As Long, Res As Variant, arr As Variant
  
  Application.ScreenUpdating = False
  Application.StatusBar = False
  Set Eccwbk = Workbooks("VTO3 Rec Model - Live.xlsm")
  Set SOFPws = Eccwbk.Sheets("SOFP")
  Set Trgws = Workbooks("Reconciliation 3 Progress Tracker - Live.xlsx").Sheets("2020")
  
  arr = Eccwbk.Sheets("Locations").Range("A2:A272").Value
  
  For i = 1 To 271
    Application.StatusBar = "Processing location : " & i
    SOFPws.Range("B4").Value = arr(i, 1)
    Eccwbk.RefreshAll
    Trgws.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("G1:G4").Value)
    Trgws.Range("G" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("H1:H4").Value)
    Trgws.Range("L" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("I1:I4").Value)
  Next i
  Application.StatusBar = False
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

 

[DanteAmor]

Let's remove another i/o to the sheet, try the following:

Sub SOFPChecksV4()
  Dim Eccwbk As Workbook, SOFPws As Worksheet, Trgws As Worksheet
  Dim i As Long, Res As Variant, arr As Variant
  Dim gArr, hArr, iArr, j As Long
 
  Application.ScreenUpdating = False
  Application.StatusBar = False
  Set Eccwbk = Workbooks("VTO3 Rec Model - Live.xlsm")
  Set SOFPws = Eccwbk.Sheets("SOFP")
  Set Trgws = Workbooks("Reconciliation 3 Progress Tracker - Live.xlsx").Sheets("2020")
 
  arr = Eccwbk.Sheets("Locations").Range("A2:A272").Value
  ReDim gArr(1 To 271, 1 To 4)
  ReDim hArr(1 To 271, 1 To 4)
  ReDim iArr(1 To 271, 1 To 4)
  For i = 1 To 271
    Application.StatusBar = "Processing location : " & i
    SOFPws.Range("B4").Value = arr(i, 1)
    Eccwbk.RefreshAll
    For j = 1 To 4
      gArr(i, j) = SOFPws.Range("G" & j).Value
      hArr(i, j) = SOFPws.Range("H" & j).Value
      iArr(i, j) = SOFPws.Range("I" & j).Value
    Next
  Next i
  Trgws.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(gArr), 4).Value = gArr
  Trgws.Range("G" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(hArr), 4).Value = hArr
  Trgws.Range("L" & Rows.Count).End(xlUp).Offset(1).Resize(UBound(iArr), 4).Value = iArr
  Application.StatusBar = False
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

 

[The Gent]

I guess the main problem is the book update. But try the folllowing.
I removed the search you had within the For.
I put all the locations in an array, each change in the For counter will put a location in cell B4, update the book and copy the data.
Try and tell me.

Sub SOFPChecksV3()
  Dim Eccwbk As Workbook, SOFPws As Worksheet, Trgws As Worksheet
  Dim i As Long, Res As Variant, arr As Variant
 
  Application.ScreenUpdating = False
  Application.StatusBar = False
  Set Eccwbk = Workbooks("VTO3 Rec Model - Live.xlsm")
  Set SOFPws = Eccwbk.Sheets("SOFP")
  Set Trgws = Workbooks("Reconciliation 3 Progress Tracker - Live.xlsx").Sheets("2020")
 
  arr = Eccwbk.Sheets("Locations").Range("A2:A272").Value
 
  For i = 1 To 271
    Application.StatusBar = "Processing location : " & i
    SOFPws.Range("B4").Value = arr(i, 1)
    Eccwbk.RefreshAll
    Trgws.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("G1:G4").Value)
    Trgws.Range("G" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("H1:H4").Value)
    Trgws.Range("L" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("I1:I4").Value)
  Next i
  Application.StatusBar = False
  Application.ScreenUpdating = True
  MsgBox "Done"
End Sub

I have just reduced the sample size to 10 for testing purposes.

The original vba took 7 minutes to run for the data set.

I am retesting now for the same sample number using your suggested code (V3).

Actually... Just completed, it took 3 minutes. Great improvement.

What is the difference with your suggestion V4?

 

[DanteAmor]

The V3 writes the result directly on the sheet.

The V4 stores the result in arrays and finally puts the arrays on the sheet.

 

[The Gent]

The V3 writes the result directly on the sheet.

The V4 stores the result in arrays and finally puts the arrays on the sheet.

Great - thank you.

I think I will stick with your suggestion of V3. It allows me to edit the code easily if I just want to take a sample as I just did.

It's a great improvement on what I had and it looks pretty neat.

Many thanks.

 

[DanteAmor]

I'm glad to help you. Thanks for the feedback.