Question

我有一个标题为任务列表的主要表格，其中包含行列表，我需要根据第I列中的单元格内容将每行复制到特定表格中。还有四个其他工作表（标题为管理，引擎，实验室， RD ），其中需要这些值复制到，取决于第一列中的值。此外，还有一个名为已完成的单独表格，其中行应移至（不复制），其中包含标题为的列E 中的单词“完成”任务列表。

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

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

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

2 个答案: