提高宏观效率

如何解决提高宏观效率

宏改进| 你好这是我在这个网站上的第一篇文章，我喜欢这里的社区我是宏的菜鸟，但我已尽力创建一个可以运行的宏，我想听听专业人士的意见，我可以在哪些方面改进我的宏，主要是它的效率。我试图用这个宏执行的任务是根据我的 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,False

wsC.Range("E6").copy
wsM.Activate
Range("AG2").PasteSpecial xlPasteValues,False

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

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

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

G = Range("AH2")
H = Cells(X,15)
ActiveSheet.Range("AG3") = StrComp(E,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,Transpose:=True
    copyB.Close
    
ElseIf 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,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

解决方法

`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。

提高效率

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,12).Value,vbTextCompare)
                .Range("AG3").Value = StrComp(.Range("AG2").Value,18).Value,vbTextCompare)
                .Range("AH3") = StrComp(.Range("AH2").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

谢谢大家的输入我能够将代码从 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,8).Value,vbTextCompare)
        wsM.Range("AG3").Value = StrComp(wsC.Range("E6").Value,11).Value,vbTextCompare)
        wsM.Range("AH3") = StrComp(wsC.Range("E5").Value,vbTextCompare)       
        wsM.Range("AI3") = StrComp(wsC.Range("E5").Value,10).Value,vbTextCompare)
        wsM.Range("AJ3") = StrComp(wsC.Range("E4").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,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

如何解决提高宏观效率

解决方法

On Error 问题

提高效率

相关推荐

`On Error` 问题