Hallo Angelina,
die Aufgabe hat mich doch gereizt.
Mit einer Hilfsspalte und zwei neuen Zeilen in xlph's Code und einem weiteren von mir entwickelten Code, habe ich, so glaube ich, eine Lösung.
Die Hilfsspalte ist im Code Spalte M, kann aber auch eine belibig andere sein.
Statt dem bisherigen Code von xlph nimmst Du folgenden:
Code:
Public Sub XLPH()
Dim lngLetzteZeile As Long
Dim lngSuchZeilenAnzahlMax As Long
Dim rngSuchwert As Range
Dim avntSuchwert() As Variant
Dim iavntSuchwert1 As Long
Dim iavntSuchwert2 As Long
Dim rngDaten As Range
Dim avntDaten() As Variant
Dim iavntDaten1 As Long
Dim iavntDaten2 As Long
Dim vntSuchwert As Variant
Dim avntErgebniswert() As Variant
Dim blnFund As Boolean
Dim rngFund As Range
Dim rngDatenLastRow As Range
With Tabelle1
Intersect(.UsedRange, .Range("D:I")).Interior.ColorIndex = xlColorIndexNone
Intersect(.UsedRange, .Range("O:Z")).Interior.Color = RGB(255, 204, 0)
Intersect(.UsedRange, .Range("AA:AL")).ClearContents
Intersect(.UsedRange, .Range("m:n")).ClearContents
lngLetzteZeile = LetzteBeschriebeneZeile(.Range("D:AL"))
If lngLetzteZeile = 0 Then Exit Sub
lngSuchZeilenAnzahlMax = Val(.Range("AM1").Value)
If lngSuchZeilenAnzahlMax = 0 Then Exit Sub
Set rngDatenLastRow = Intersect(.Range("D:I"), .Rows(lngLetzteZeile))
Set rngSuchwert = .Range("O1:Z" & lngLetzteZeile)
avntSuchwert() = rngSuchwert.Value
avntErgebniswert() = .Range("AA1:AL" & lngLetzteZeile).Value
For iavntSuchwert1 = LBound(avntSuchwert, 1) To UBound(avntSuchwert, 1)
Set rngDaten = .Range("D" & iavntSuchwert1).Resize(lngSuchZeilenAnzahlMax, 6)
avntDaten() = rngDaten.Value
For iavntSuchwert2 = LBound(avntSuchwert, 2) To UBound(avntSuchwert, 2)
vntSuchwert = avntSuchwert(iavntSuchwert1, iavntSuchwert2)
If Not IsEmpty(vntSuchwert) Then
For iavntDaten1 = LBound(avntDaten, 1) To UBound(avntDaten, 1)
For iavntDaten2 = LBound(avntDaten, 2) To UBound(avntDaten, 2)
If avntDaten(iavntDaten1, iavntDaten2) = vntSuchwert Then
avntErgebniswert(iavntSuchwert1, iavntSuchwert2) = iavntDaten1
blnFund = True: Exit For
End If
Next
If blnFund Then Exit For
Next
If blnFund Then
rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = RGB(192, 192, 192)
rngDaten.Cells(iavntDaten1, iavntDaten2).Interior.Color = RGB(192, 192, 192)
If Cells(iavntDaten1 + iavntSuchwert1 - 1, 13) < 3 Then Cells(iavntDaten1 + iavntSuchwert1 - 1, 13) = Cells(iavntDaten1 + iavntSuchwert1 - 1, 13) + 1
blnFund = False
Else
Set rngFund = Range(rngDaten.Rows(1), rngDatenLastRow).Find(vntSuchwert, , xlValues, xlWhole)
If Not rngFund Is Nothing Then
If rngFund.Interior.Color <> RGB(192, 192, 192) Then
rngFund.Interior.Color = vbYellow
If Cells(rngFund.Row, 13) < 3 Then Cells(rngFund.Row, 13) = Cells(rngFund.Row, 13) + 1
End If
rngSuchwert.Cells(iavntSuchwert1, iavntSuchwert2).Interior.Color = vbYellow
Else
End If
End If
End If
Next
Set rngDaten = Nothing
Next
.Range("AA1:AL" & lngLetzteZeile).Value = avntErgebniswert()
End With
Erase avntDaten
Erase avntErgebniswert
Erase avntSuchwert
Set rngDatenLastRow = Nothing
Set rngSuchwert = Nothing
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
Nach Ausführung des obigen Codes folgenden ausführen:
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
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
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
Set rngC = rngB.Find(Cells(i, j), , xlValues, xlWhole)
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) & "#", "")
End If
Else
If InStr(strgSammlung, Cells(i, j)) = 0 Then strgSammlung = strgSammlung & "#" & Cells(i, j)
End If
End If
Next j
Next i
If UBound(Split(strgSammlung, "#")) > 0 Then Cells(lngZZ + k - 1, 40) = UBound(Split(strgSammlung, "#"))
k = lngZZ + 1
Next pp
Range(Cells(merkZ, 4), Cells(lngZd, 9)).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