VBA 代码 - 如果满足条件，将数据复制到新工作表

Question

我正在尝试使用 VBA 将数据复制到 Excel 中的新工作表。我希望在标记为“完成”时将数据传输到工作表。我对下面代码的问题是数据总是移动到表 2 中的 B 行，反复覆盖自身。我希望将数据复制到第二张表中 B、C、D、E 等列中的新行。

代码：

Sub Move_When_Completed()
'Created by Excel 10 Tutorial
    
    Dim xRg As Range
    Dim xCell As Range
    Dim A As Long
    Dim B As Long
    Dim C As Long

    A = Worksheets("To_Do").UsedRange.Rows.Count
    B = Worksheets("Done").UsedRange.Rows.Count

    If B = 1 Then
       If Application.WorksheetFunction.CountA(Worksheets("Done").UsedRange) = 0 Then B = 0
    End If

    Set xRg = Worksheets("To_Do").Range("E1:E" & A)

    On Error Resume Next
    
    Application.ScreenUpdating = False
    
    For C = 1 To xRg.Count
        If CStr(xRg(C).Value) = "Complete" Then
            xRg(C).EntireRow.Copy Destination:=Worksheets("Done").Range("A" & Rows.Count).End(xlUp).Offset(1)
            xRg(C).EntireRow.Delete
            If CStr(xRg(C).Value) = "Complete" Then
                C = C - 1
            End If
            B = B + 1
        End If
    Next

    Application.ScreenUpdating = True

End Sub

................................

Answer 1

移动匹配行

Sub MoveCompleted()
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    ' If it isn't, reference it by name or use 'ActiveWorkbook'.
    
    ' Reference the source objects.
    Dim sws As Worksheet: Set sws = wb.Sheets("To_Do")
    Dim srg As Range: Set srg = sws.UsedRange.Columns("E")
    
    ' Reference the destination objects.
    Dim dws As Worksheet: Set dws = wb.Sheets("Done")
    Dim dcell As Range:
    With dws.UsedRange.EntireRow.Columns("A")
        Set dcell = .Cells(.Cells.Count).Offset(1)
    End With
    
    ' Declare additional variables.
    Dim surg As Range, sRow As Long, scell As Range
    
    ' Loop through the cells of the source range
    ' and add the matching (completed) cells to a unioned range.
    For Each scell In srg.Cells
        If CStr(scell.Value) = "Complete" Then ' E<>e
        'If StrComp(CStr(scell.Value), "Complete", vbTextCompare) = 0 Then ' E=e
            If surg Is Nothing Then
                Set surg = scell
            Else
                Set surg = Union(surg, scell)
            End If
        End If
    Next scell

    ' Check if any matching cells were found and retrieve their number.
    Dim MatchingRowsCount As Long
    If Not surg Is Nothing Then MatchingRowsCount = surg.Cells.Count
    
    ' Copy and delete the entirerows of the unioned range.
    If MatchingRowsCount > 0 Then
        Application.ScreenUpdating = False
            With surg.EntireRow
                .Copy Destination:=dcell
                .Delete Shift:=xlShiftUp
            End With
        Application.ScreenUpdating = True
    End If
    
    ' Inform.
    If MatchingRowsCount > 0 Then
        MsgBox MatchingRowsCount & " completed row" _
            & IIf(MatchingRowsCount = 1, "", "s") & " moved.", vbInformation
    Else
        MsgBox "No completed rows found!", vbExclamation
    End If

End Sub