Optimering af VBA kode

Jeg har en kolonne med tal som jeg så ønsker at skal sammenlignes så hvis der er et tal som er mere en gang på listen så skal alle dataen på den række hvor tallet er kopiere over i et andet ark.
F.eks.
1
2
3
4
5
6
3
8
3
2

Så skal de rækker hvor 2 og 3 er på kopieres over i andet ark.

Der er tale om et ark med 35000 rækker af data... så tjekket tager noget tid. VBA kan ses nedenfor, og ved en test på 5185 rækker så tog det omkring 2½ min at kører det hele igennem… Da jeg er forholdsvis ny i at programmere med VB så ville jeg høre om der var nogen som kunne komme med nogle råd til hvordan programmet kan gøres hurtigere…
Skal jeg sætte starte med at indsætte alt dataen i et array eller hvad? Håber på lidt vejledning…
Og jeg ved godt at starten af min kode ikke er særlig pæn og variabler er ikke så logisk skrevet, så hvis det er helt galt og ikke til at forstå så skal jeg nok skrive dem om…

    Dim startTal As Double
    Dim iTaeller() As Double
    Dim x As Range, x2 As Range, x3 As Range, x4 As Range, c As Range
 
    Dim y As Integer, r As Integer, tjek As Integer
    Dim taller As Long
    Dim old As String
    Dim pcrt As Integer
 
    Dim tekst As String
    Dim tl As Double, tie As Integer, ialt As Long
    Dim saml_datatb() As Range
    Dim ertaget As Boolean
   
    'Fastsætter destination for hvor at de kopierede rækker skal placeres
    Set x2 = ThisWorkbook.Worksheets("Ark2").Cells(1, 2)
    tl = 0
    taller = 0
 
    old = Application.DisplayStatusBar
    Application.DisplayStatusBar = True
   
    'Finder antallet af rækker som der bruges i statusbar.
    Set x4 = ThisWorkbook.Worksheets("Ark1").Range("B3").End(xlDown)
    ialt = x4.Row
 
    'Sætter startTal lig med værdien i den enkelte celle
    For Each x In ThisWorkbook.Worksheets("Ark1").Range("J3", Range("J3").End(xlDown)).Cells
        startTal = 0
        startTal = x.Value
        ertaget = True
       
     
        tie = 0
        'Undersøger om tallet er blevet tjekket før... Hvis det er så springes det over
        If tl > 0 Then
            For r = 0 To tl - 1

                    If startTal = iTaeller(r) Then
                        ertaget = False

                End If
            Next
        End If
        'Hvis tallet ikke er blevet tjekket før så tjekkes det.
        'Først så indsættes det i arrayet iTaeller og derefter undersøges det om tallet findes i de næste celler
        If ertaget = True Then
            ReDim Preserve iTaeller(tl)
            iTaeller(tl) = startTal
            tl = tl + 1
            tie = 0
            For Each x3 In ThisWorkbook.Worksheets("Ark1").Range(x.Address, Range(x.Address).End(xlDown)).Cells
                If x3.Value = startTal Then
             
                    ReDim Preserve saml_datatb(tie)
                    Set saml_datatb(tie) = x3
                    tie = tie + 1
             
                End If
         
            Next
            'Hvis tallet er fundet mere end 1 gang så udskrives de pågældende rækker på destinationen
            If tie > 1 Then
                For y = 0 To tie - 1
             
                    saml_datatb(y).EntireRow.Copy Destination:=x2.EntireRow
                    Set x2 = ThisWorkbook.Worksheets("Ark2").Cells((x2.Row) + 1, x2.Column)
               
                Next
            End If
        End If
        'Udskriver hvor langt at processen er nået...
        taller = taller + 1
        pcrt = (taller / ialt) * 100
        tekst = taller & " ud af " & ialt & " (" & pcrt & "%)"
        Application.StatusBar = tekst
    Next
 
 
 
    Application.StatusBar = False
    Application.DisplayStatusBar = old