根据单元格自动将行复制到工作表

Question

我有一个标题为 Task List 的主工作表，其中包含行列表，我需要根据 Column I 中单元格的内容将每一行复制到特定工作表中强>。还有其他四个工作表（标题为 Admin、Engine、Lab 和 RD）需要提供这些值复制到，具体取决于 Column I 中的值。此外，还有一个名为 Completed 的单独工作表，其中行应移动到（而不是复制）其中在标题为 的工作表的 Column E 中包含单词“Complete”任务列表。

以下是我目前从我找到的帖子中获取的代码。当我运行它时，它当前没有复制任何东西。任何人都可以建议新代码或对此进行修改吗？

Sub copyRows()

Set a = Sheets("Task List")
Set b = Sheets("Admin")
Set c = Sheets("Engine")
Set d = Sheets("Lab")
Set e = Sheets("RD")
Set f = Sheets("Completed")
Dim t
Dim u
Dim v
Dim w
Dim y As Long
Dim z

t = 2
u = 2
v = 2
w = 2
z = 3

Do Until IsEmpty(a.Range("I" & z))
    If a.Range("I" & z) = "Admin" Then
        t = t + 1
        b.Rows(t).Value = a.Rows(z).Value
    End If

    If a.Range("I" & z) = "Engine" Then
        u = u + 1
        c.Rows(u).Value = a.Rows(z).Value
    End If

    If a.Range("I" & z) = "Lab" Then
        v = v + 1
        d.Rows(v).Value = a.Rows(z).Value
    End If

    If a.Range("I" & z) = "RD" Then
        w = w + 1
        e.Rows(w).Value = a.Rows(z).Value
    End If

    If a.Range("E" & z) = "COMPLETE" Then
        y = f.Range("a" & Rows.Count).End(xlUp).Row + 1
        f.Rows(y).Value = a.Rows(z).Value
        a.Rows(z).Delete
        z = z - 1
    End If

    z = z + 1
Loop

End Sub

Answer 1

我认为循环无法正常工作。试试这个代码：

Sub copyRows()

Set a = Sheets("Task List")
Set b = Sheets("Admin")
Set c = Sheets("Engine")
Set d = Sheets("Lab")
Set e = Sheets("RD")
Set f = Sheets("Completed")
Dim t, u, v, w, y, CountLng As Long

CountLng = ActiveSheet.UsedRange.Rows.Count

t = 2
u = 2
v = 2
w = 2
z = 3

For z = CountLng to 3 step -1


    If a.Range("I" & z) = "Admin" Then
    t = t + 1
    b.Rows(t).Value = a.Rows(z).Value

    ElseIf a.Range("I" & z) = "Engine" Then
    u = u + 1
    c.Rows(u).Value = a.Rows(z).Value

    ElseIf a.Range("I" & z) = "Lab" Then
    v = v + 1
    d.Rows(v).Value = a.Rows(z).Value

    ElseIf a.Range("I" & z) = "RD" Then
    w = w + 1
    e.Rows(w).Value = a.Rows(z).Value
    End If

    If a.Range("E" & z) = "COMPLETE" Then
    y = f.Range("a" & Rows.Count).End(xlUp).Row + 1
    f.Rows(y).Value = a.Rows(z).Value
    a.Rows(z).Delete

    End If

Next z

End Sub

Answer 2

尝试AutoFilter 方法，您会发现它在处理大型数据集时更短、更快。

注意：将Set FilterRng = a.Range(a.Range("I3"), a.Range("I3").End(xlDown))修改为您的数据所在的列。

Option Explicit

Sub copyRows()

Dim a As Worksheet
Dim SheetNames As Variant, ShtInd As Variant, FilterRng As Range
Dim CopyRng As Range

Set a = Sheets("Task List")

SheetNames = Array("Admin", "Engine", "Lab", "RD", "Completed")

a.Range("I3").AutoFilter ' <-- expand the range where your data lies

Set FilterRng = a.Range(a.Range("I3"), a.Range("I3").End(xlDown))

' loop through all sheet names in array, except "Task List"
For Each ShtInd In SheetNames

    ' check if there is a match before setting the AutoFilter (not to get an error)
    If Not IsError(Application.Match(ShtInd, a.Range(a.Range("I3"), a.Range("I3").End(xlDown)), 0)) Then
        FilterRng.AutoFilter Field:=1, Criteria1:=ShtInd ' <-- sut autofilter according to sheet name

        Set CopyRng = FilterRng.SpecialCells(xlCellTypeVisible) ' <-- set range to only visible rows
        CopyRng.EntireRow.Copy Sheets(ShtInd).Range("A" & Sheets(ShtInd).Cells(Sheets(ShtInd).Rows.Count, "I").End(xlUp).Row + 1) ' <-- Copy >> paste the entire range to all sheets to first empty row

        If ShtInd Like "Completed" Then
            CopyRng.EntireRow.Delete xlShiftUp   ' <-- delete the entire range related to sheet "Completed"
        End If
    End If

    FilterRng.AutoFilter Field:=1 ' <-- reset filter
Next ShtInd

End Sub