abominations chimériques (ne posez pas de questions sur les noms de macro lol facepalm

Option Explicit
Sub Brian()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet

Set sh = Sheets("Dup")
lw = Range("A" & Rows.Count).End(xlUp).Row

    For i = 1 To lw 'Find duplicates from the list.
       If Application.CountIf(Range("A" & i & ":A" & lw), Range("A" & i).Text) > 1 Then
            Range("B" & i).Value = 1
        End If
    Next i

    Range("A1:B10000").AutoFilter , Field:=2, Criteria1:=1
    Range("C2", Range("C65536").End(xlUp)).EntireRow.Copy
    sh.Range("C65536").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Selection.AutoFilter
End Sub

Sub bowietwo()
'Updateby Extendoffice
    Dim xRgS As Range
    Dim xRgD As Range
    Dim i As Long, J As Long
    On Error Resume Next
    Set xRgS = Application.InputBox("Please select the column:", "Hi! John says:", Selection.Address, , , , , 8)
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Application.InputBox("Please select a desitination cell:", "Hi! John says:", , , , , , 8)
    If xRgD Is Nothing Then Exit Sub
    xRows = xRgS.Rows.Count
    J = 0
    For i = xRows To 1 Step -1
        If Application.WorksheetFunction.CountIf(xRgS, xRgS(i)) > 1 Then
            xRgS(i).EntireRow.Copy xRgD.Offset(J, 0)
            xRgS(i).EntireRow.Delete
            J = J + 1
        End If
    Next
End Sub

Sub bowie()
    Dim xRgS As Range
    Dim xRgD As Range
    Dim i As Long, J As Long
    On Error Resume Next
    Set xRgS = Range("C:C")
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Worksheets(2)
    If xRgD Is Nothing Then Exit Sub
    xRows = xRgS.Rows.Count
    J = 0
    For i = xRows To 1 Step -1
        If Application.WorksheetFunction.CountIf(xRgS, xRgS(i)) > 1 Then
            xRgS(i).EntireRow.Copy xRgD.Offset(J, 0)
            xRgS(i).EntireRow.Delete
            J = J + 1
        End If
    Next
End Sub

celui-ci ^^ sorta fonctionne mais plante tout de suite, ma liste d'animaux est dans les dizaines de milliers

Option Explicit
Sub pinky()
Dim lw As Long
Dim i As Integer
Dim sh As Worksheet

Set sh = Sheets("Sheet1")`
lw = Range("A" & Rows.Count).End(xlUp).Row`

For i = 1 To lw 'Find duplicates from the list.
       If Application.CountIf(Range("C" & i & ":C" & lw), Range("C" & i).Text) > 1 Then
       Range("C2", Range("C65536").End(xlUp)).EntireRow.Copy
       sh.Range(Worksheets(2)).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    Selection.AutoFilter

           ' Range("C" & i).Value = 1
        End If
    Next i    

End Sub

donc, pinky, bowie, bowietwo et brian se sont révélés inutiles. Je sais qu'il doit y avoir une manière simple et élégante de le faire.

Unique Magic

Téléchargement du classeur (Dropbox)

Le code

Sub UniqueMagic()

    Const cFR As Long = 1             ' Header Row Number
    Const cFC As Variant = "A"        ' First Column Letter/Number
    Const cColU As Variant = "C"      ' Unique Column Letter/Number
    Const cSheet As String = "Sheet"  ' Worksheet Pattern

    Dim ws As Worksheet   ' Source (Unique) Worksheet
    Dim wsK As Worksheet  ' Keep Worksheet
    Dim rng As Range      ' LucH - Last Used Cell (Range) in Header Row
                          ' LucU - Last Used Cell (Range) in Unique Column
    Dim dict As Object    ' Dictionary
    Dim key As Variant    ' Dictionary Key (For Each Control Variable)
    Dim vntS As Variant   ' Source Array
    Dim vntR As Variant   ' Row Array
    Dim vntU As Variant   ' Unique Array
    Dim vntK As Variant   ' Keep Array
    Dim NorS As Long      ' Source Number of Rows
    Dim NorU As Long      ' Unique Number of Rows
    Dim NorK As Long      ' Keep Number of Rows
    Dim Noc As Long       ' Number of Columns
    Dim FC As Long        ' First Column Number
    Dim ColU As Long      ' Source Array Unique Column Number
    Dim i As Long         ' Source/Keep Array Row Counter
    Dim j As Long         ' Column Counter
    Dim k As Long         ' Row/Unique Array Row Counter
    Dim strSh As String   ' Keep Worksheet Name Concatenator

    ' Speed up.
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    ' Handle unexpected error.
    On Error GoTo ErrorHandler

    ' Task: Write values from Source Worksheet (ws) to Source Array (vntS).

    ' Create a reference to Source Worksheet.
    Set ws = ThisWorkbook.ActiveSheet
    ' In Source Worksheet
    With ws
        ' Calculate and create a reference to LucH.
        Set rng = .Columns(cColU).Find("*", , xlFormulas, , , xlPrevious)
        ' Write row number of LucH to Number of Rows.
        NorS = rng.Row - cFR + 1
        ' Calculate and create a reference to LucU.
        Set rng = .Rows(cFR).Find("*", , xlFormulas, , , xlPrevious)
        ' Calculate First Column Number.
        FC = .Columns(cFC).Column
        ' Write row number of LucU to Number of Columns.
        Noc = rng.Column - FC + 1
        ' Calculate Source Array Unique Column Number.
        ColU = .Columns(cColU).Column - FC + 1
        ' Calculate Source Range.
        ' Copy Source Range to Source Array.
        vntS = .Cells(cFR, cFC).Resize(NorS, Noc)
    End With

    ' Task: Write Source Array row numbers (i) for first found ('unique')
    '       values to Dictionary (dict) and row numbers (i) for again found
    '       values to Row Array (vntR).

    ' Resize 1D 1-based Row Array to Source Number of Rows.
    ReDim vntR(1 To NorS)
    ' Create a reference to Dictionary.
    Set dict = CreateObject("Scripting.Dictionary")
    ' Loop through Rows of Source Array (first row are headers).
    For i = 2 To NorS
        ' Check if current value in Source Array does not exists in Dictionary.
        If Not dict.Exists(vntS(i, ColU)) Then ' Does NOT exist in Dictionary.
            ' Add current value in Source Array to Key and current Source
            ' Row Number in Source Array to Value of Dictionary.
            dict.Add vntS(i, ColU), i
          Else ' Does EXIST in Dictionary.
            ' Count number of elements in Row Array.
            k = k + 1
            ' Write current Source Row Number to current row in Row Array.
            vntR(k) = i
        End If
    Next

    ' Task: Write from Source Array (vntS) to Keep Array (vntK).

    ' Check if any 'non-unique' values have been found.
    If k = 0 Then GoTo UniqueMessage ' Inform user.
    ' Resize Row Array to current row count of Row Array (k) i.e.
    ' remove empty values.
    ReDim Preserve vntR(1 To k)
    ' Write size (rows) of Row Array to Keep Number of Rows.
    NorK = k + 1 ' + 1 for Headers
    ' Resize Keep Array to Keep Number of Rows and Number of Columns.
    ReDim vntK(1 To NorK, 1 To Noc)
    ' Write Headers from Source Array to Keep Array.
    For j = 1 To Noc
        vntK(1, j) = vntS(1, j)
    Next
    ' Write Body Keep Values from Source array to Keep Array.
    For i = 2 To NorK
        For j = 1 To Noc
            vntK(i, j) = vntS(vntR(i - 1), j)
        Next
    Next
    Erase vntR ' No longer needed. Data is in Keep Array.

    ' Task: Copy Keep Array (vntK) to Keep Range (rng) in newly created
    '       Keep Worksheet(wsK).

    ' Write Source Worksheet Name to Keep Worksheet Name Concatenator.
    strSh = ws.Name
    ' Apply numbering to Worksheet Name Concatenator.
    strSh = cSheet & CStr(Right(strSh, Len(strSh) - Len(cSheet)) + 1)
    ' Delete possible existing Keep Worksheet.
    Application.DisplayAlerts = False
        On Error Resume Next
            ThisWorkbook.Worksheets(strSh).Delete
        On Error GoTo 0
    Application.DisplayAlerts = True
    ' Handle unexpected error.
    On Error GoTo ErrorHandler
    ' Copy Source Worksheet after itself.
    ws.Copy After:=ws
    ' Create a reference to the newly created Keep Worksheet, which is
    ' the ActiveSheet now.
    Set wsK = ActiveSheet
    ' In Keep Worksheet
    With wsK
        ' Rename Keep Worksheet to value (string) of Keep Worksheet Name
        ' Concatenator.
        .Name = strSh
        ' Calculate and clear rows below Keep Range.
        .Rows(NorK + cFR).Resize(.Rows.Count - NorK - cFR + 1).Clear
        ' Calculate and create a reference to Keep Range.
        Set rng = .Cells(cFR, FC).Resize(NorK, Noc)
        ' Copy Keep Array to Keep Range.
        rng = vntK
    End With
    Erase vntK ' No longer needed. Data in Keep Range.

    ' Task: Write from Source Array (vntS) to Unique Array (vntU).

    ' Caclulate Unique Number of Rows.
    NorU = dict.Count + 1 ' + 1 for Headers
    ' Resize Unique Array to Unique Number of Rows and Number of Columns.
    ReDim vntU(1 To NorU, 1 To Noc)
    ' Reset Unique Array Row Counter.
    k = 1
    ' Write Headers from Source Array to Unique Array.
    For j = 1 To Noc
        vntU(1, j) = vntS(1, j)
    Next
    ' Write Body Unique Values from Source array to Unique Array.
    For Each key In dict
        k = k + 1
        For j = 1 To Noc
            vntU(k, j) = vntS(dict(key), j)
        Next
    Next
    Erase vntS ' No longer needed. Data in Keep Range and Unique Array.
    dict.RemoveAll ' No longer needed. Data in Unique Array.

    ' Task: Copy Unique Array (vntU) to Unique Range (rng) in
    '       Source Worksheet (ws).

    ' In Source Worksheet
    With ws
        ' Calculate and clear rows below Unique Range.
        .Rows(NorU + cFR).Resize(.Rows.Count - NorU - cFR + 1).Clear
        ' Calculate and create a reference to Unique Range.
        Set rng = .Cells(cFR, FC).Resize(NorU, Noc)
        ' Copy Unique Array to Unique Range.
        rng = vntU
    End With
    Erase vntU ' No longer needed. Data is in Unique Range.

ProcedureExit:

    ' Speed Down.
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With

Exit Sub

UniqueMessage:
    MsgBox "All values are unique.", vbInformation, "Unique"
    GoTo ProcedureExit

ErrorHandler:
    MsgBox "An unexpected error occurred. Error '" & Err.Number & "': " _
            & Err.Description, vbCritical, "Error"
    GoTo ProcedureExit

End Sub

J'ai essayé sur la ligne de votre travail et essayé de rester simple

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

le code peut être facilement exécuté une fois comme vous le souhaitiez, mais s'il est essayé de boucler pour les nouvelles feuilles générées, il peut planter comme votre liste d'animaux peut dépasser des milliers de rangées et en conservant un ensemble de 10 animaux, elle peut ajouter 100 feuilles. Ainsi, même après l'ajout de la mise à jour de l'écran d'événement de calcul standard, il avait tendance à se bloquer sur environ 700 lignes si la boucle externe est activée.

Une autre solution de contournement simple a donc été essayée où la liste d'origine des animaux était conservée intacte et chaque les listes uniques sont sorties sur la 2ème feuille avec une ligne vide entre elles. ici, une autre colonne dit que D est utilisée ici pour garder une trace de la liste déjà utilisée. Le code comme suit

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

Résultat du code 2