提高宏观效率
Improve Macro Efficiency
宏改进|
您好，这是我第一次 post 访问此站点，我喜欢这里的社区
我是宏的新手，但我已尽力创建一个功能宏，我想听听专业人士的意见，我可以改进我的宏，主要是它的效率。我试图用这个宏执行的任务是根据我的 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
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
这个例子抛出一个错误；
Run time error '11'
Division by zero
现在，如果我们将错误处理程序移动到 1/0 行上方，
Sub foo()
On Error GoTo Safety:
Debug.Print 1 / 0
Exit Sub
Safety:
Debug.Print "Safety!"
End Sub
此示例将 Safety! 输出到 VBE 中的 Immediate window。
至于 审查 您的代码以进行改进等，这个问题更适合另一个 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, _
.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
谢谢大家的意见我能够将代码从 160 行减少到 90 行并实现更高的功能，同时还需要更少的变量。这是我最终 result.Also 实现的 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
宏改进| 您好，这是我第一次 post 访问此站点，我喜欢这里的社区 我是宏的新手，但我已尽力创建一个功能宏，我想听听专业人士的意见，我可以改进我的宏，主要是它的效率。我试图用这个宏执行的任务是根据我的 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
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
这个例子抛出一个错误；
Run time error '11' Division by zero
现在，如果我们将错误处理程序移动到 1/0 行上方，
Sub foo()
On Error GoTo Safety:
Debug.Print 1 / 0
Exit Sub
Safety:
Debug.Print "Safety!"
End Sub
此示例将 Safety! 输出到 VBE 中的 Immediate window。
至于 审查 您的代码以进行改进等，这个问题更适合另一个 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, _
.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
谢谢大家的意见我能够将代码从 160 行减少到 90 行并实现更高的功能，同时还需要更少的变量。这是我最终 result.Also 实现的 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