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]

 

[Fluff]

Which sheet on the tracker do you want to paste the info to?

 

[Norie]

I don't think it's the activating that's slowing things down, though that probably won't help.

It's more likely this loop here.

       For Each cell In ws.Columns(2).Cells
            If IsEmpty(cell) = True Then cell.Select: Exit For
        Next cell

If you are trying to paste into the next empty row try this.

Sub SOFPChecks()
'
' Macro7 Macro
'
' Keyboard Shortcut: Ctrl+o
'

Dim ws As Worksheet
Dim n As Long
Dim v As Variant

    Application.ScreenUpdating = False
    
    Do Until n = 26
        n = n + 1
        
        Workbooks("Ecc vs S4 v6.xlsm").Sheets("SOFP").Range("G1:G4").Copy
        
        Workbooks("Reconciliation 1 Progress Tracker - Live.xlsx").ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=True
                             
        With Workbooks("Ecc vs S4 v6.xlsm").Sheets("SOFP")
        
            If .Value = "" Then
                .Value = Workbooks("Ecc vs S4 v6.xlsm").Sheets("Locations").Range("A2").Value
            Else
                v = Application.Match(.Value, Workbooks("Ecc vs S4 v6.xlsm").Sheets("Locations").Range("A2:A263"), 0)
                If IsNumeric(v) Then
                    .Value = Workbooks("Ecc vs S4 v6.xlsm").Sheets("Locations").Range("A2:A263").Cells(v + 1, 1).Value
                Else
                    .Value = ""
                End If
            End If
        End With
        
        Workbooks("Ecc vs S4 v6.xlsm").RefreshAll
        
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

PS I also got rid of the activating.

 

[The Gent]

Which sheet on the tracker do you want to paste the info to?

I usually just open the sheet of where I want it to paste to but it should be pasted to a worksheet named "2018".

 

[jimrward]

Unless I have missed something what is n doing

 

[Fluff]

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

 

[Fluff]

Unless I have missed something what is n doing

It's regulating the loop.

 

[The Gent]

Unless I have missed something what is n doing

Do Until n = 26
n = n + 1

​

At the moment I am using this to define the amount of times to loop the macro. I have to do it 262 times (based on a data validation list) but I just put 26 for now to break it up.

 

[jimrward]

At the moment n is not referenced within the block

 

[The Gent]

I don't think it's the activating that's slowing things down, though that probably won't help.

It's more likely this loop here.

       For Each cell In ws.Columns(2).Cells
            If IsEmpty(cell) = True Then cell.Select: Exit For
        Next cell

If you are trying to paste into the next empty row try this.

Sub SOFPChecks()
'
' Macro7 Macro
'
' Keyboard Shortcut: Ctrl+o
'

Dim ws As Worksheet
Dim n As Long
Dim v As Variant

    Application.ScreenUpdating = False
    
    Do Until n = 26
        n = n + 1
        
        Workbooks("Ecc vs S4 v6.xlsm").Sheets("SOFP").Range("G1:G4").Copy
        
        Workbooks("Reconciliation 1 Progress Tracker - Live.xlsx").ActiveSheet.Range("B" & Rows.Count).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
            :=False, Transpose:=True
                             
        With Workbooks("Ecc vs S4 v6.xlsm").Sheets("SOFP")
        
            If .Value = "" Then
                .Value = Workbooks("Ecc vs S4 v6.xlsm").Sheets("Locations").Range("A2").Value
            Else
                v = Application.Match(.Value, Workbooks("Ecc vs S4 v6.xlsm").Sheets("Locations").Range("A2:A263"), 0)
                If IsNumeric(v) Then
                    .Value = Workbooks("Ecc vs S4 v6.xlsm").Sheets("Locations").Range("A2:A263").Cells(v + 1, 1).Value
                Else
                    .Value = ""
                End If
            End If
        End With
        
        Workbooks("Ecc vs S4 v6.xlsm").RefreshAll
        
    Loop
    
    Application.ScreenUpdating = True
    
End Sub

PS I also got rid of the activating.

I got an error when I ran this on the below line...

If .Value = "" Then