VBA - Alternative to Activate to speed up macro

The Gent

Board Regular
Joined
Jul 23, 2019
Messages
50
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:

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]
 
Last edited by a moderator:
jimrward

n is being used as a kind of loop control variable, see here.
Code:
Do Until n = 26
    n=n+1

    ' code

Loop
 
Upvote 0

Excel Facts

Copy PDF to Excel
Select data in PDF. Paste to Microsoft Word. Copy from Word and paste to Excel.
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
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
Ok, how about
Code:
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.
 
Upvote 0
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.
 
Upvote 0
You're welcome & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top