Пробовал на линии вашей работы и старался быть простым
Sub test()
Dim SrcRw As Long, SrclastRow As Long, SrcWs As Worksheet, TrgWs As Worksheet
Dim TrgRw As Long, TrglastRow As Long
Dim Animal As String, Rng As Range, C As Range, firstAddress As String
'Do
Set SrcWs = ThisWorkbook.Sheets(1)
SrcRw = 1
TrgRw = 1
Do While SrcWs.Cells(SrcRw, 3).Value <> ""
Animal = SrcWs.Cells(SrcRw, 3).Value
With SrcWs.Range("C" & SrcRw + 1 & ":C" & Rows.Count)
Set C = .Find(Animal, LookIn:=xlValues)
If Not C Is Nothing Then
firstAddress = C.Address
Do
If Rng Is Nothing Then
Set Rng = C
Else
Set Rng = Union(Rng, C)
End If
'Debug.Print C.Address
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
If Not Rng Is Nothing Then
If TrgWs Is Nothing Then Set TrgWs = ThisWorkbook.Worksheets.Add(ThisWorkbook.Sheets(1))
Rng.EntireRow.Copy TrgWs.Range("A" & TrgRw)
TrgRw = TrgWs.Range("A" & TrgWs.Rows.Count).End(xlUp).Row + 1
Rng.EntireRow.Delete
End If
Set Rng = Nothing
SrcRw = SrcRw + 1
Loop
' If TrgWs Is Nothing Then
' Exit Sub
' End If
'Set TrgWs = Nothing
'Loop
End Sub
код может быть легко запущен один раз, как вам требуется, но если попытаться выполнить цикл для новых сгенерированных листов, он может потерпеть крах, так как ваш список животных может превышать тысячи строк и при сохранении набора из 10 животных он может добавить 100 листов , Таким образом, даже после добавления обновления экрана стандартного события вычислений, при включенном внешнем цикле, была тенденция к сбоям около 700 строк.
Таким образом, был предпринят другой простой обходной путь, при котором исходный список животных был сохранен, и каждый набор уникальных списков выводился на 2-й лист с пустой строкой между ними. здесь другой столбец говорит, что D используется здесь, чтобы отследить уже использованный список. Код следующим образом
Sub test2()
Dim SrcRw As Long, SrclastRow As Long, SrcWs As Worksheet, TrgWs As Worksheet
Dim TrgRw As Long, TrglastRow As Long, LoopNo As Long
Dim Animal As String, Rng As Range, C As Range, firstAddress As String
Dim AnimalCol As String, Dummy As Variant, Lcnt() As Long
Dummy = InputBox("Enter Column Letter,Source Sheet Name And Target Sheet Name seperated by Comma", "Input Source & targets", "C,Sheet1,Sheet2")
If Len(Dummy) <= 0 Then
MsgBox " Invalid input"
Exit Sub
Else
Dummy = Split(Dummy, ",")
If UBound(Dummy) < 2 Then
MsgBox " Invalid input, All parameters are not entered"
Exit Sub
End If
End If
AnimalCol = Dummy(0)
Set SrcWs = ThisWorkbook.Sheets(Dummy(1))
Set TrgWs = ThisWorkbook.Sheets(Dummy(2))
TrgRw = 1
LoopNo = 1
SrclastRow = SrcWs.Range("A" & SrcWs.Rows.Count).End(xlUp).Row + 1
ReDim Lcnt(1 To SrclastRow)
For SrcRw = 1 To SrclastRow
Lcnt(SrcRw) = 1
Next
Do
Set Rng = Nothing
SrcRw = 1
Do While SrcWs.Cells(SrcRw, AnimalCol).Value <> ""
If Lcnt(SrcRw) = LoopNo Then
Animal = SrcWs.Cells(SrcRw, AnimalCol).Value
If Rng Is Nothing Then
Set Rng = SrcWs.Cells(SrcRw, 1)
Else
Set Rng = Union(Rng, SrcWs.Cells(SrcRw, 1))
End If
With SrcWs.Range(AnimalCol & SrcRw + 1 & ":" & AnimalCol & SrclastRow)
Set C = .Find(Animal, LookIn:=xlValues)
If Not C Is Nothing Then
firstAddress = C.Address
Do
Lcnt(C.Row) = LoopNo + 1
Set C = .FindNext(C)
Loop While Not C Is Nothing And C.Address <> firstAddress
End If
End With
End If
SrcRw = SrcRw + 1
Loop
If Not Rng Is Nothing Then
Rng.EntireRow.Copy TrgWs.Range("A" & TrgRw)
TrgRw = TrgWs.Range("A" & TrgWs.Rows.Count).End(xlUp).Row + 2
Else
Exit Do
End If
Set Rng = Nothing
LoopNo = LoopNo + 1
Loop
End Sub
Результат кода 2
