Question

我创建了一个excel VBA脚本，根据该行中项目的状态将行移动到不同的工作表。但是，当我运行代码时，如果有多个状态更新，它并不总是一次移动所有项目。我想这样做，如果多行有状态更新，当我运行脚本时，他们都会立即移动。我假设它与“if语句”有关，但我在任何其他方法上都是空白。任何帮助是极大的赞赏。谢谢！

以下是我的代码：

Sub MoveRows()
Dim xRg As Range
Dim xCell As Range
Dim A As Long
Dim B As Long
Dim C As Long
Dim D As Long
A = Worksheets("Tracking").UsedRange.Rows.Count
B = Worksheets("In Progress").UsedRange.Rows.Count
C = Worksheets("Completed").UsedRange.Rows.Count
D = Worksheets("Removed").UsedRange.Rows.Count
If B = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("In Progress").UsedRange) = 0 Then B = 0
ElseIf C = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Completed").UsedRange) = 0 Then C = 0
ElseIf D = 1 Then
   If Application.WorksheetFunction.CountA(Worksheets("Removed").UsedRange) = 0 Then D = 0
    End If
Set xRg = Worksheets("Tracking").Range("S1:S" & A)
On Error Resume Next
Application.ScreenUpdating = False
For Each xCell In xRg
    If CStr(xCell.Value) = "In Progress" Then
        xCell.EntireRow.Copy Destination:=Worksheets("In Progress").Range("A" & B + 1)
        xCell.EntireRow.Delete
        B = B + 1
    ElseIf CStr(xCell.Value) = "Completed" Then
        xCell.EntireRow.Copy Destination:=Worksheets("Completed").Range("A" & C + 1)
        xCell.EntireRow.Delete
        C = C + 1
    ElseIf CStr(xCell.Value) = "Remove" Then
        xCell.EntireRow.Copy Destination:=Worksheets("Removed").Range("A" & D + 1)
        xCell.EntireRow.Delete
        D = D + 1
    End If
Next
Application.ScreenUpdating = True
End Sub

Answer 1

已修改以添加所选行删除

确保在＆＃34;跟踪＆＃34;中有一个标题行工作表然后AutoFilter()将使您的生活像以下代码一样简单：

Option Explicit

Sub MoveRows()
    Application.ScreenUpdating = False

    With Worksheets("Tracking")
        With .Range("S1", .Cells(.Rows.count, "S").End(xlUp))
            FilterAndCopy .Cells, "In Progress"
            FilterAndCopy .Cells, "Completed"
            FilterAndCopy .Cells, "Remove"
        End With
    End With

    Application.ScreenUpdating = True
End Sub

Sub FilterAndCopy(rng As Range, filterStrng As String)
    With rng '<--| reference passed 'rng' range
        .AutoFilter Field:=1, Criteria1:=filterStrng '<--| filter its 1st column with passed 'filterStrng'
        If Application.WorksheetFunction.Subtotal(103, .Resize(, 1)) > 1 Then '<--| if any cell filtered other than header
            With .Resize(.Rows.count).Offset(1).SpecialCells(xlCellTypeVisible).EntireRow
                .Copy Destination:=Worksheets(filterStrng).Cells(Rows.count, "A").End(xlUp).Offset(1)  '<--|copy filtered cells (skipping headers row) to passed 'filterStrng' named worksheet 1st column from its column A first empty row after last not empty one
                .Delete
            End With
        End If
        .Parent.AutoFilterMode = False
    End With
End Sub

VBA - 根据条件将行移动到不同的行只能一次运行一行

1 个答案: