「myrange」循環繼續處理超出範圍末尾的問題

Question

我遇到了一個宏，它應該依次搜索每個mycell的myrange，並將它複製到另一個工作表（如果在GL工作表中找到它） 。然而，它繼續在myrange中的單元之後運行（即，它繼續在myrange下的所有空白行上運行）。 myrange只是10行數據。這裏是代碼：

Dim myrange As Range 
Dim mycell As Range 

    Set wbProjects = Workbooks("Expense Project Jobs.xlsx") 
    Set wbGL = Workbooks("GL.xml") 
    Set wbProjectJournal = Workbooks("Expense Project Journal.xlsx") 

wbProjects.Activate 
LastrowJob1 = Sheets("Project_Costs").Range("F" & Rows.Count).End(xlUp).Row 
Set myrange = Range("F2:F" & LastrowJob1) 

'LOOP START 

For Each mycell In myrange 
If mycell = "" Then 
GoTo ErrorHandlerMyCell 
End If 

mycell.Copy 
wbGL.Activate 

On Error GoTo ErrorHandlerMyCell 

Range("A1").Activate 
Cells.Find(What:=mycell, After:=ActiveCell, LookIn:=xlValues, LookAt _ 
     :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _ 
     False, SearchFormat:=False).Activate 

    On Error GoTo 0 

    ActiveCell.EntireRow.Cut 
    wbProjectJournal.Activate 
    Range("A1").Activate 
    If Range("A2") <> "" Then 
    GoTo NextCode2 

NextCode2: 
    Selection.End(xlDown).Select 
    ActiveCell.Offset(1, 0).Select 
    Activesheet.Paste 
    wbGL.Activate 
    ActiveCell.EntireRow.Delete 

    Else 
    Range("A2").Select 
    Activesheet.Paste 

    End If 

NextCode1: 
    Next mycell 

ErrorHandlerMyCell: 
    Resume NextCode1 

End Sub 

Answer 1

你知道你的代碼會在最後運行ErrorHandlerMyCell而不管是否有錯誤嗎？它不是一個單獨的模塊，只有在出現錯誤時才被調用，但是觸發主程序的一部分。也許你可以ErrorHandlerMyCell

Exit Sub 
ErrorHandlerMyCell: 
Resume NextCode1 
End Sub 

Answer 2

前添加一個退出小組的代碼有大量冗餘的，它似乎被覆蓋在Row 3複製單元格時，在A2是wbProjectJournal空記錄。

我還建議將工作表設置爲objects而不是工作簿。實際上，代碼最終會在工作簿中的任何活動工作表激活後結束。如果只有一張紙，或者如果只有一張是必需的，那麼它現在可以工作，但這只是一個巧合，而不是一個好習慣。

有一點需要強調的是過度和不正確使用的是什麼意圖充當Error Handlers（見本頁On Error Statement爲了更好地理解），也提高了使用對象看到這個With Statement

下面的代碼應該解決這一問題，（已插入註釋來解釋的變化）：

Option Explicit 

Sub TEST_Solution() 
Dim wbProjects As Workbook, wbGL As Workbook, wbProjectJournal As Workbook 
Dim rTrg As Range, rCll As Range, rCllTrg As Range 
Dim rFnd As Range, vWhat As Variant 

    Set wbProjects = Workbooks("Expense Project Jobs.xlsx") 
    Set wbGL = Workbooks("GL.xml") 
    Set wbProjectJournal = Workbooks("Expense Project Journal.xlsx") 
    wbProjects.Activate 

    Rem Set Range from wbProjects\Project_Costs\Column F 
    'use [With] to perform several statements on the same object 
    'see https://msdn.microsoft.com/en-us/library/office/gg264723(v=office.15).aspx 
    With wbProjects.Sheets("Project_Costs").Columns(6) 
     Set rTrg = Range(.Cells(2), .Cells(Rows.Count).End(xlUp)) 
    End With 

    Rem Search for the value of each cell in the no-empty cells of 
    For Each rCll In rTrg 

     Rem Set & Validate cell value 
     vWhat = rCll.Value2 
     If vWhat <> Empty Then 

      Rem Activate range to apply the FIND method 
      'Replace [1] with the name of the worksheet where the search is run 
      With wbGL.Sheets(1) 
       .Application.Goto .Cells(1), 1 

       Rem Set cell with found value 
       Set rFnd = .Cells.Find(What:=vWhat, After:=ActiveCell, _ 
        LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, _ 
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False) 

       If Not (rFnd Is Nothing) Then 

        Rem Activate range to apply the FIND method 
        'Replace [1] with the name of the worksheet where the search is performed 
        With wbProjectJournal.Sheets(1).Cells(2, 1) 
         If .Value2 = Empty Then 
          Rem A2 = Blank then Paste in row 2 only 
          rFnd.EntireRow.Copy 
          .PasteSpecial 
          Application.CutCopyMode = False 

         ElseIf .Offset(1).Value2 = Empty Then 
          Rem A3 = Blank then Paste in row 3 & delete record found 
          rFnd.EntireRow.Copy 
          .Offset(1).PasteSpecial 
          Application.CutCopyMode = False 
          rFnd.EntireRow.Delete 

         Else 
          Rem Paste below last row & delete record found 
          rFnd.EntireRow.Copy 
          .End(xlDown).Offset(1).PasteSpecial 
          Application.CutCopyMode = False 
          rFnd.EntireRow.Delete 

     End If: End With: End If: End With: End If: Next 

End Sub