首页 文章

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

提问于
浏览 次
0

我有一个 Headers 为 Task List 的主页，其中包含行列表，我需要根据 Column I 中单元格的内容将每行复制到特定的表格中 . 还有四个其他工作表（ Headers 为 Admin ， Engine ， Lab 和 RD ），其中需要将这些值复制到，具体取决于 Column I 中的值 . 此外，还有一个名为 Completed 的单独工作表，其中行应移至（不复制），其中包含 Headers 为 Task List 的工作表的 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
excel vba excel-vba excel-2010

2 回答

  • 0

    我认为循环不能正常工作 . 试试这段代码：

    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
    回复于
  • 0

    尝试使用 AutoFilter 方法，在处理大型数据集时，您会发现它更短，速度更快 .

    Note ：将 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
    回复于

相关问题