Автоматически копировать строки в листе на основе ячейки

Question

У меня есть основной лист под названием Список задач со списком строк, и мне нужно каждый ряд должен быть скопирован на конкретный лист на основе содержимого ячеек в Колонка I , Есть четыре других листов (под названием Администратор, двигателя, Лаборатория и РД), где должны быть скопированы, в зависимости от значения в Колонка I эти значения. Кроме того, существует отдельный лист с именем Завершено, где строки должны перемещаться (не копировать), содержащие слово «Завершить» в Столбец 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