To je možda moglo i formulama da se uradi. U svakom slučaju evo ti makro:
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