VBA - Alternative to Activate to speed up macro

[The Gent]

Hi,

I currently have a macro which is copying data from a form and pasting it into a log in a different workbook. The form is pulling data from an external database and thus takes a long time to refresh and my macro is looping this 262 times! At the moment it's taking circa 40 minutes to perform. Is there anyway to speed this up? I have noticed that when the macro is running it is switching between workbooks, possibly due to the activate function.

Current code:

[FONT=Verdana]Sub SOFPChecks()
'
' Macro7 Macro
'
' Keyboard Shortcut: Ctrl+o
'
Application.ScreenUpdating = False
Dim n As Integer
n = 0
Do Until n = 26
    n = n + 1
    Sheets("SOFP").Range("G1:G4").Copy
    Windows("Reconciliation 1 Progress Tracker - Live.xlsx").Activate
     Dim ws As Worksheet
    Set ws = ActiveSheet
    For Each cell In ws.Columns(2).Cells
        If IsEmpty(cell) = True Then cell.Select: Exit For
    Next cell
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Windows("Ecc vs S4 v6.xlsm").Activate
     Dim v As Variant
    With Sheets("SOFP").Range("B4")
        If .Value = "" Then
            .Value = Sheets("Locations").Range("A2").Value
        Else
            v = Application.Match(.Value, Sheets("Locations").Range("A2:A263"), 0)
            If IsNumeric(v) Then
                .Value = Sheets("Locations").Range("A2:A263").Cells(v + 1, 1).Value
            Else
                .Value = ""
            End If
        End If
    End With
    ActiveWorkbook.RefreshAll
Loop
Application.ScreenUpdating = True
End Sub
[/FONT]

 

[Norie]

jimrward

n is being used as a kind of loop control variable, see here.

Do Until n = 26
    n=n+1

    ' code

Loop

 

[jimrward]

Yes I understand loops and have done for over 40 years of programming on numerous platforms and languages I am just pointing out it’s redundancy in this context and all it’s doing is repeating the same block 26 times and if one iteration is not optimal then the timing will be compounded by n iterations

 

[Fluff]

The workbook is being refreshed during the loop, so new values are being pulled in, therefore each iteration is working on "fresh" data.
Hence the loop is not redundant.

 

[The Gent]

The workbook is being refreshed during the loop, so new values are being pulled in, therefore each iteration is working on "fresh" data.
Hence the loop is not redundant.

That's right, the code triggers a data validation list to select the next item, then refreshing the form with the new data.

 

[The Gent]

Ok, how about

Sub SOFPChecks()
   Dim Eccwbk As Workbook
   Dim SOFPws As Worksheet, Trgws As Worksheet
   Dim i As Long
   Dim Res As Variant
   
   Set Eccwbk = Workbooks("Ecc vs S4 v6.xlsm")
   Set SOFPws = Eccwbk.Sheets("SOFP")
   Set Trgws = Workbooks("Reconciliation 1 Progress Tracker - Live.xlsx").Sheets("2018")
   
   Application.ScreenUpdating = False
   For i = 1 To 26
      Sheets("SOFP").Range("G1:G4").Copy
      Trgws.Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(, 4).Value = Application.Transpose(SOFPws.Range("G1:G4").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:A263"), 0)
            If IsNumeric(Res) Then
               .Value = Eccwbk.Sheets("Locations").Range("A2:A263").Cells(Res + 1, 1).Value
            Else
               .Value = ""
            End If
         End If
      End With
      Eccwbk.RefreshAll
   Next i
End Sub

However you said it's looping 262 times, but the code is only looping 26 times

Ok - this seems like it is working much quicker, however the data now pastes further down in terms of rows in the "2018" worksheet. Is it looking for the first blank cell? As I have some functions in rows 267:270.

 

[The Gent]

Ok - this seems like it is working much quicker, however the data now pastes further down in terms of rows in the "2018" worksheet. Is it looking for the first blank cell? As I have some functions in rows 267:270.

Never mind, I will move the functions at the bottom to another sheet. After this the new code you provided works perfectly and most of all quickly.

Thank you.

 

[Fluff]

You're welcome & thanks for the feedback