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

{ "keys": ["ctrl+y"], "command": "show_overlay", "args": {"overlay": "command_palette", "text": "Snippet: "}}

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

“myrange”循环的问题继续处理超出范围的末尾

2 个答案: