AW: Anzahl duplikate zählen
21.11.2011 10:11:50
Dirk
Hallo!
Hier mal als macro:
Sub Count_Differences()
'This macro count the differences rows and presents the overall count
Dim MyArr As Variant
Dim FirstRow As Long
Dim LastRow As Long
Dim i As Long, k As Long, m As Long
Dim ArrRows As Long
'set first row
FirstRow = 4
'set Lastrow
LastRow = Sheets("Sheet1").Range("A65536").End(xlUp).Row
'redim array (0-4 = values, 5=count, 6 = row number)
ReDim MyArr(6, 0)
'loop through Range
For i = FirstRow To LastRow
If ArrRows > 0 Then
'search array for similarities
For k = 0 To ArrRows
For m = 0 To 4
If MyArr(m, k) = Cells(i, m + 1).Value Then
mcount = mcount + 1
Else
mcount = 0
Exit For
End If
Next m
If mcount = 5 Then
'match found, adjust array count
MyArr(5, k) = MyArr(5, k) + 1
Exit For
End If
Next k
'check, if similary was found in array
If mcount = 0 Then
'not found, add array row
For k = 1 To 5
MyArr(k - 1, ArrRows) = Cells(i, k)
Next k
MyArr(k - 1, ArrRows) = 1
MyArr(6, ArrRows) = i
ArrRows = ArrRows + 1
ReDim Preserve MyArr(6, ArrRows)
End If
Else
'first assignment of array
For k = 1 To 5
MyArr(k - 1, 0) = Cells(i, k)
Next k
MyArr(k - 1, 0) = 1
MyArr(6, 0) = i
ArrRows = ArrRows + 1
ReDim Preserve MyArr(6, ArrRows)
End If
Next i
'present results
For i = 0 To ArrRows - 1
Sheets("Sheet1").Cells(MyArr(6, i), 6).Value = MyArr(5, i)
Next i
End Sub
Gruss
Dirk aus Dubai