Improve Macro Efficiency

Question

Macro Improvement| Hello This is my first post on this site,I love the community here I am rookie in macros but I have tried my best to create one functioning macro, I would like to hear opinion of professionals where I could improve my macro, mainly efficiency of it. The task I am trying to perform with this macro is to Open Workbook based on cells in my MainB workbook, then compare 3 strings in these two workbooks and if they match copy and paste them to original file, close the previous and continue. The error I have right now is after the macro encounters the non-existent file location it closes main workbook and does not continue. If by any chance it continues then it gives me an error message, which it shouldn't as I have specified what to do 'OnError'.

 Sub DoCopyandRepeat()

Dim MainB As Workbook
Dim CopyB As Workbook
Dim wsM As Worksheet
Dim wsC As Worksheet
Dim A, B, C, D, E, F, G, H As Variant
Dim X As Integer

Set MainB = ThisWorkbook

Set wsM = MainB.Worksheets("Sheet1")

AfterError:

For X = 3 To 10 Step 1

If Cells(X, 23).Value = "" Then
Workbooks.Open Filename:="C:\Users\XY\OneDrive - XX\Desktop\Macro book"

Set MainB = ThisWorkbook
Set wsM = MainB.Worksheets("Sheet1")
MainB.Activate

Workbooks.Open Filename:="C:\Users\XY\OneDrive - XX\Desktop\Folder1\Folder2\" & Worksheets("Sheet1").Cells(X, 5) & "\Folder3\" & Worksheets("Sheet1").Cells(X, 12) & "\" & Worksheets("Sheet1").Cells(X, 14)
    On Error GoTo Reset:

    End If
    
Set CopyB = ActiveWorkbook
Set wsC = CopyB.ActiveSheet

wsC.Range("E4").Copy
wsM.Activate
Range("AE2").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, False

wsC.Range("C4").Copy
wsM.Activate
Range("AF2").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, False

wsC.Range("E6").Copy
wsM.Activate
Range("AG2").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, False

wsC.Range("E5").Copy
wsM.Activate
Range("AH2").PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, True, False
    
A = Range("AE2")
B = Cells(X, 15)
ActiveSheet.Range("AE3") = StrComp(A, B, vbTextCompare)

C = Range("AF2")
D = Cells(X, 12)
ActiveSheet.Range("AF3") = StrComp(C, D, vbTextCompare)

E = Range("AG2")
F = Cells(X, 18)
ActiveSheet.Range("AG3") = StrComp(E, F, vbTextCompare)

G = Range("AH2")
H = Cells(X, 15)
ActiveSheet.Range("AG3") = StrComp(E, F, vbTextCompare)

If Cells(3, 31) = 0 And Cells(3, 32) = 0 And Cells(3, 33) = 0 Then
    CopyB.Activate
    Range("G4:G10").Copy
    MainB.Activate
    Cells(X, 23).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, Transpose:=True
    CopyB.Close
    
ElseIf Cells(3, 32) = 0 And Cells(3, 33) = 0 And Cells(3, 34) = 0 Then

    CopyB.Activate
    Range("G6:G10").Copy
    MainB.Activate

    CopyB.Activate
    Range("G5").Copy
    MainB.Activate
    Cells(X, 23).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
    
    CopyB.Activate
    Range("G4").Copy
    MainB.Activate
    Cells(X, 24).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone
    CopyB.Close
    
Else
    Cells(X, 23) = "failure"

CopyB.Close

End If

ActiveWorkbook.Save
Application.Wait (Now + TimeValue("0:00:05"))

Reset:

Next X
Resume AfterError

End Sub

Answer 1

The On Error issue

Your On Error GoTo line should be before the code you want to handle.

If you step through your code using F8 in the VBE, if the workbook you want to open doesn't exist for example, the code has executed before your On Error handler, hence you are receiving an error on screen.

To avoid the error appearing on screen and for your code to perform as expected, try like this;

...
Set MainB = ThisWorkbook
Set wsM = MainB.Worksheets("Sheet1")
MainB.Activate

On Error GoTo Reset

Workbooks.Open Filename:="C:\Users\XY\OneDrive - XX\Desktop\Folder1\Folder2\" & Worksheets("Sheet1").Cells(X, 5) & "\Folder3\" & Worksheets("Sheet1").Cells(X, 12) & "\" & Worksheets("Sheet1").Cells(X, 14)

End If
...

This way, if you step through the code you would see the On Error code is executed the line before your Workbooks.Open line and thus if an error is thrown, the code now knows to goto Reset

As a simple example, the following sub has an error handler and tries to divide by zero (which you cannot do.).

Sub foo()

Debug.Print 1 / 0
On Error GoTo Safety:

Exit Sub
Safety:
Debug.Print "Safety!"
End Sub

This example throws an error;

Run time error '11' Division by zero

Now if we move the Error handler above the 1/0 line,

Sub foo()

On Error GoTo Safety:

Debug.Print 1 / 0

Exit Sub
Safety:
Debug.Print "Safety!"
End Sub

This example with output Safety! to the Immediate window in the VBE.

---

As for a review of your code for improvements etc, this question would be better suited for another Stack Exchange site: Code Review .

Answer 2

Improve Efficiency

Option Explicit

Sub DoCopyandRepeat()
     
    Dim dwb As Workbook: Set dwb = ThisWorkbook
    Dim dws As Worksheet: Set dws = dwb.Worksheets("Sheet1")
    
    Dim swb As Workbook
    Dim i As Long
    
    For i = 3 To 10
    
        ' Attempt to open the Source Workbook.
        Set swb = Nothing
        If dws.Cells(i, 23).Value = "" Then ' Unclear, edit appropriately.
            Set swb = Workbooks.Open( _
                Filename:="C:\Users\XY\OneDrive - XX\Desktop\Macro book")
        Else
            On Error Resume Next
            Set swb = Workbooks.Open( _
                Filename:="C:\Users\XY\OneDrive - XX\Desktop\Folder1\Folder2\" _
                & dws.Cells(i, 5).Value & "\Folder3\" _
                & dws.Cells(i, 12).Value & "\" _
                & dws.Cells(i, 14).Value)
            On Error GoTo 0
        End If
        
        If Not swb Is Nothing Then ' if file was opened
        
            Dim sws As Worksheet: Set sws = swb.ActiveSheet
            
            With dws
                
                .Range("AE2").Value = sws.Range("E4").Value
                .Range("AF2").Value = sws.Range("C4").Value
                .Range("AG2").Value = sws.Range("E6").Value
                .Range("AH2").Value = sws.Range("E5").Value
                    
                .Range("AE3").Value = StrComp(.Range("AE2").Value, _
                    .Cells(i, 15).Value, vbTextCompare)
                .Range("AF3").Value = StrComp(.Range("AF2").Value, _
                    .Cells(i, 12).Value, vbTextCompare)
                .Range("AG3").Value = StrComp(.Range("AG2").Value, _
                    .Cells(i, 18).Value, vbTextCompare)
                .Range("AH3") = StrComp(.Range("AH2").Value, _
                    .Cells(i, 15).Value, vbTextCompare) ' suspicious
             
                If .Cells(3, 31).Value = 0 And .Cells(3, 32).Value = 0 _
                        And .Cells(3, 33).Value = 0 Then
                    swb.Range("G4:G10").Copy
                    .Cells(i, 23).PasteSpecial xlPasteValues, _
                        xlPasteSpecialOperationNone, Transpose:=True
                ElseIf .Cells(3, 32).Value = 0 And .Cells(3, 33).Value = 0 _
                        And .Cells(3, 34).Value = 0 Then
                    swb.Range("G6:G10").Copy
                    '.Cells... ' Missing Paste???
                    .Cells(i, 23).Value = swb.Range("G5").Value
                    .Cells(i, 24).Value = swb.Range("G4").Value
                Else
                    .Cells(i, 23).Value = "failure"
                End If
                
                swb.Close SaveChanges:=False
            
            End With
            
            dwb.Save
            Application.Wait (Now + TimeValue("0:00:05")) ' ???
        
        'Else
            
            ' File was not opened: do nothing.
        
        End If
    
    Next i

End Sub

Answer 3

Thanks, everyone for input I was able to cut down the code from 160 lines to 90 and achieve higher functionality, whilst also requiring less variables. Here is my final result.Also Implemented dir function so it searches for specific file in folder. I still believe it could be done even better, but it suffices for current task.

Sub CopyPaste()

Dim MainB As Workbook
Dim CopyB As Workbook
Dim wsM As Worksheet
Dim wsC As Worksheet
Dim X As Integer
Dim Folder As String
Dim XFile As String
Dim temp As Variant
Set MainB = ThisWorkbook
Set wsM = MainB.Worksheets("DATA")

AfterError:

For X = 3 To 204 Step 1

 If wsM.Cells(X, 16).Value = "" Then
    Folder = "C:\Users\USERXY\FolderLevel1\FolderLevel2\FolderLevel3\XX" & Worksheets("DATA").Cells(X, 1)
    XFile = Dir(Folder & "*short*")
    Workbooks.Open (Folder & XFile)
    On Error GoTo Reset:
    ElseIf Cells(X, 16).Value <> "" Then GoTo ErrorContinue:
    
End If
        
Set CopyB = ActiveWorkbook
Set wsC = CopyB.ActiveSheet
    
    wsC.Range("G4:G10").Copy
    wsM.Cells(X, 16).PasteSpecial xlPasteValues, xlPasteSpecialOperationNone, 
    Transpose:=True
                        
        wsM.Range("AE3").Value = StrComp(wsC.Range("E4").Value, _
           wsM.Cells(X, 9).Value, vbTextCompare)
        wsM.Range("AF3").Value = StrComp(wsC.Range("C4").Value, _
           wsM.Cells(X, 8).Value, vbTextCompare)
        wsM.Range("AG3").Value = StrComp(wsC.Range("E6").Value, _
           wsM.Cells(X, 11).Value, vbTextCompare)
        wsM.Range("AH3") = StrComp(wsC.Range("E5").Value, _
           wsM.Cells(X, 9).Value, vbTextCompare)       
        wsM.Range("AI3") = StrComp(wsC.Range("E5").Value, _
           wsM.Cells(X, 10).Value, vbTextCompare)
        wsM.Range("AJ3") = StrComp(wsC.Range("E4").Value, _
           wsM.Cells(X, 10).Value, vbTextCompare)
           
           
    If wsM.Range("AE3").Value <> 0 And wsM.Range("AH3") = 0 Then
        
        wsM.Cells(X, 16) = wsC.Range("G5")
        wsM.Cells(X, 17) = wsC.Range("G4")
        wsM.Range("AE3").Value = StrComp(wsC.Range("E5").Value, _
        wsM.Cells(X, 9).Value, vbTextCompare) 'Recheck Switch
    End If
    
    If wsM.Range("AF3").Value <> 0 Then
        wsM.Cells(X, 28) = "Type 0 Miss match"
    Else: wsM.Cells(X, 28) = "Fit"
    End If
    
    If wsM.Range("AE3").Value <> 0 Then
        wsM.Cells(X, 29) = "Type 1 Miss match"
    Else: wsM.Cells(X, 29) = "Fit"
    End If
    
    If wsM.Range("AG3").Value <> 0 Then
        wsM.Cells(X, 30) = " Type 2 Miss match"
    Else: wsM.Cells(X, 30) = "Fit"
    End If
 
    If wsM.Range("AI3").Value = 0 Or wsM.Range("AJ3").Value = 0 Then
        wsM.Cells(X, 27) = "Fit"
    Else: wsM.Cells(X, 27) = " Mismatch or Missing"
    End If
    
CopyB.Close

Application.Wait (Now + TimeValue("0:00:05"))
ErrorContinue:
Next X
Exit Sub
Reset:
Cells(X, 16) = "File Location Unavailable"
Resume ErrorContinue:
End Sub