21.03.2016, 21:28
Hallo Angelina,
jetzt testen:
jetzt testen:
Code:
Sub zählen()
Dim i As Long, j As Long, pp As Long, k As Long
Dim lngZd As Long, lngZZ
Dim merkZ As Long
Dim anzahlDreier As Long
Dim strgSammlung As String
Dim rngB As Range, rngC As Range
Dim firstAddress As String
Dim boVar As Boolean
lngZd = LetzteBeschriebeneZeile(Range("D:I"))
Columns("AN").ClearContents
anzahlDreier = Application.CountIf(Columns("M"), 3)
If anzahlDreier = 0 Then Exit Sub
merkZ = Application.Match(3, Columns("M"), 0)
k = 1
Application.ScreenUpdating = False
For pp = 1 To anzahlDreier - 1
lngZZ = Application.Match(3, Range(Cells(k, 13), Cells(lngZd, 13)), 0)
Set rngB = Range("D1:I" & lngZZ + k - 2)
For i = 1 To lngZZ + k - 1
For j = 15 To 26
If Cells(i, j) <> "" Then
With rngB
Set rngC = .Find(Cells(i, j), , xlValues, xlWhole)
If Not rngC Is Nothing Then
firstAddress = rngC.Address
Do
Set rngC = .FindNext(rngC)
If Not rngC Is Nothing Then
If rngC.Interior.ColorIndex = xlColorIndexNone Then
If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & rngC
Else
If InStr(strgSammlung, Cells(i, j)) Then strgSammlung = Replace(strgSammlung, "#" & Cells(i, j), "")
Exit Do
End If
End If
Loop While rngC.Address <> firstAddress
Else
If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & Cells(i, j)
End If
End With
End If
Next j
Next i
If UBound(Split(strgSammlung, "#")) > 0 Then
Cells(lngZZ + k - 1, 40) = UBound(Split(strgSammlung, "#"))
Else
Cells(lngZZ + k - 1, 40) = 0
End If
k = k + lngZZ + 1
Next pp
' Range(Cells(merkZ, 4), Cells(lngZd, 9)).Clear
' Range(Cells(merkZ+1, 15), Cells(lngZd, 38)).Clear
' Columns("M").Clear
Application.ScreenUpdating = True
End sub
Public Function LetzteBeschriebeneZeile(ByRef rngBereich As Range) As Long
On Error Resume Next
LetzteBeschriebeneZeile = rngBereich.Find("*", , xlFormulas, xlWhole, xlByRows, xlPrevious).Row
End Function
- jedenfalls kaum bei größeren Bereichen. Für das Beispiel ist das ja noch überschaubar.