Poređenje podataka jedne kolone i kopiranje u drugi Sheet

Code:
Option Explicit
Option Base 1

Sub subViseOdPet()
Dim lngBrojRedova As Long
Dim i As Long, j As Long, r As Long
Dim colKolekcija As New Collection
Dim arrMatrica()
Dim arrRezultat()

'prebrojavamo koliko imamo redova sa podacima
lngBrojRedova = WorksheetFunction.CountA(Worksheets("Sheet1").Range("A:A"))
'prebacujemo sve podatke u matricu
arrMatrica() = Worksheets("Sheet1").Range("A1:E" & lngBrojRedova).Value

'sve podatke iz prve kolone matrice stavljamo u kolekciju koristeći sam podatak kao ključ. Javiće se greške jer ključ
'mora biti jedinstven. Mi koristimo to svojstvo da izdvojimo jedinstvene podatke.
On Error Resume Next
For i = 1 To lngBrojRedova
    colKolekcija.Add Item:=arrMatrica(i, 1), Key:=CStr(arrMatrica(i, 1))
Next i
On Error GoTo 0

r = 1
For i = 1 To colKolekcija.Count
    'za svaki jedinstven podatak proveravamo da li se ponavlja više od 5 puta.
    If WorksheetFunction.CountIf(Worksheets("Sheet1").Range("A1:A" & lngBrojRedova), colKolekcija.Item(i)) > 5 Then
        For j = 1 To lngBrojRedova
            'ako se ponavlja više od pet puta, svako ponavljanje takvog rezultata stavljamo u arrRezultat matricu.
            'ova matrica ima obrnute kolone i redove jer "Redim Preserve" komanda dozvoljava da menjamo samo poslednju dimenziju.
            If arrMatrica(j, 1) = colKolekcija.Item(i) Then
                ReDim Preserve arrRezultat(5, r)
                arrRezultat(1, r) = arrMatrica(j, 1)
                arrRezultat(2, r) = arrMatrica(j, 2)
                arrRezultat(3, r) = arrMatrica(j, 3)
                arrRezultat(4, r) = arrMatrica(j, 4)
                arrRezultat(5, r) = arrMatrica(j, 5)
                r = r + 1
            End If
        Next j
    End If
Next i

'da bismo vratili rezultat u tabelu moramo da aktiviramo Sheet2, da ga očistimo od starih rezuultata.
'posle toga samo ubacimo matricu arrRezultat u worksheet, ali je prvo transponujemo jer smo joj obrnuli kolone i redove.
Worksheets("Sheet2").Activate
Worksheets("Sheet2").Range("A1").CurrentRegion.Clear
Worksheets("Sheet2").Range(Cells(1, 1), Cells(UBound(arrRezultat, 2), UBound(arrRezultat, 1))).Value = WorksheetFunction.Transpose(arrRezultat)

End Sub