提高宏观效率

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:UsersXYOneDrive - XXDesktopMacro book"
Set MainB = ThisWorkbook
Set wsM = MainB.Worksheets("Sheet1")
MainB.Activate
Workbooks.Open Filename:="C:UsersXYOneDrive - XXDesktopFolder1Folder2" & 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:UsersXYOneDrive - XXDesktopFolder1Folder2" & 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网站：代码审查。

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:UsersXYOneDrive - XXDesktopMacro book")
Else
On Error Resume Next
Set swb = Workbooks.Open( _
Filename:="C:UsersXYOneDrive - XXDesktopFolder1Folder2" _
& 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:UsersUSERXYFolderLevel1FolderLevel2FolderLevel3XX" & 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