仅在满足条件时复制一次图纸，然后删除该图纸

Question

我有多张工作表，希望在满足条件时将该工作表复制到另一个工作簿。条件是比较通过列Abs(R & lRow +2)和列AC & lRow + 3的单元格中的值。只要有一个比较符合条件，就会复制图纸。如果在一张工作表的比较中满足条件N次，我当前的代码将复制工作表N次。有没有关于如何防止这种情况并且只复制一次的建议？此外，我在复制后添加了sh.delete，但这会使宏复制1张工作表，然后停止工作。一个错误消息"；收到自动化错误"。对这个问题有什么建议吗？提前感谢您的任何帮助或建议！

Sub TES_copy()
Const ProcName As string = "TES_copy"
On Error GoTo clearError
Dim wb As Workbook: Set wb = Workbooks("A.xlsx")
Dim TESwb As Workbook: Set Teswb = Workbooks("B.xlsx")
Dim sh As Worksheet
Dim sCount As Long
Dim lRow As Long
Dim i As Long
Dim ColArray As Variant
Application.ScreenUpdating = False
For Each sh In wb.Worksheets
lRow = sh.Cells(sh.Rows.Count,1).End(xlUp).Row
ColArray = Array("R","S","T","U","V","W","X","Y","Z","AA","AB","AC")
For i = LBound(ColArray) To UBound(ColArray)
If Abs(sh.Range(ColArray(i) & lRow + 2)) > sh.Range(ColArray(i) & lRow +3) Then
sCount = sCount + 1
sh.Copy After:=TESwb.Sheets(TESwb.Sheets.Count)
End If
Next i
Next sh
ProcExit:
If Not Application.ScreenUpdating Then
Application.ScreenUpdating = True  
End If
Select Case sCount
Case 0 
MsgBox "No worksheets copied.", vbExclamation, "Fail?"
Case 1
MsgBox "Copied 1 worksheet.", vbInformation, "Success"
Case Else
MsgBox "Copied " & sCount & " of A worksheets to B workbook.", vbInformation, "Success"
End Select
clearError:
Debug.Print "'" & ProcName & "':Unexpected Error!" & vbLf & " " & "Run-time error'" & Err.Number & "':";vbLf & " " & Err.Description
Resume ProcExit
End Sub

Answer 1

您可以使用Exit For语句在复制工作表后退出For循环

For Each Sheet...
For i = LBound(ColArray) To UBound(ColArray)
If Some Condition Is Met
Copy Sheet
Exit For ' this will exit the inner For i = LBound(... loop
End If
Next i
Next Sheet