Question

宏改进| 你好这是我在这个网站上的第一篇文章，我喜欢这里的社区我是宏的菜鸟，但我已尽力创建一个可以运行的宏，我想听听专业人士的意见，我可以在哪些方面改进我的宏，主要是它的效率。我试图用这个宏执行的任务是根据我的 MainB 工作簿中的单元格打开工作簿，然后比较这两个工作簿中的 3 个字符串，如果它们匹配，则将它们复制并粘贴到原始文件中，关闭上一个并继续。我现在遇到的错误是在宏遇到不存在的文件位置后，它关闭了主工作簿并且不再继续。如果有任何机会它继续，那么它会给我一条错误消息，它不应该，因为我已经指定了“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

`On Error` 问题

您的 On Error GoTo 行应该在您要处理的代码之前。

如果您在 VBE 中使用 F8 单步执行代码，例如，如果您要打开的工作簿不存在，则代码已在您的 On Error 处理程序之前执行，因此您在屏幕上收到错误消息。

为了避免错误出现在屏幕上并使您的代码按预期执行，请尝试这样做；

...
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
...

这样，如果您单步执行代码，您会看到 On Error 代码在 Workbooks.Open 行之前的行执行，因此如果抛出错误，代码现在知道转到 Reset

举个简单的例子，下面的子程序有一个错误处理程序，并试图除以零（你不能这样做！）。

Sub foo()

Debug.Print 1 / 0
On Error GoTo Safety:

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

这个例子抛出一个错误；

<块引用>

运行时错误“11” 除以零

现在，如果我们将错误处理程序移到 1/0 行上方，

Sub foo()

On Error GoTo Safety:

Debug.Print 1 / 0

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

此示例将 Safety! 输出到 VBE 中的立即窗口。

至于对您的代码进行改进等的审查，这个问题更适合另一个 Stack Exchange 站点：Code Review。

Answer 2

提高效率

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

谢谢大家的输入我能够将代码从 160 行减少到 90 行并实现更高的功能，同时还需要更少的变量。这是我的最终结果。还实现了 dir 函数，因此它在文件夹中搜索特定文件。我仍然相信它可以做得更好，但它足以完成当前的任务。

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

提高宏观效率

3 个答案:

`On Error` 问题

提高效率

提高宏观效率

3 个答案:

On Error 问题

提高效率

`On Error` 问题