Hallo Angelina,
jetzt bekommst Du Deine 14. Ich habe mich extra beeilt, damit Du morgen den Jackpot knacken kannst :19:
Folgenden Code in ein Modul:
Code:
Public Sub XLPHAN_1()
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
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)
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
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
zählen2
End Sub
Public Sub XLPHAN_2()
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
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)
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 rngFund.Row = 127 Then Stop
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
Sub zählen2()
Dim lngLetzteZeile As Long
Dim i As Long, j As Long, k As Long
Columns("M").ClearContents
lngLetzteZeile = LetzteBeschriebeneZeile(Range("D:I"))
For i = 1 To lngLetzteZeile
For j = 4 To 9
If Cells(i, j).Interior.ColorIndex <> xlColorIndexNone Then
k = k + 1
End If
Next j
If k >= 3 Then Cells(i, 13) = Application.Max(Columns("M")) + 1
k = 0
Next i
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
Folgenden in ein andres Modul:
Code:
Sub zählen()
Dim i As Long, j As Long, pp As Long
Dim lngZd As Long, lngZZ
Dim strgSammlung As String
lngZd = LetzteBeschriebeneZeile(Range("D:AL"))
Columns("AN").ClearContents
XLPHAN_1
Application.ScreenUpdating = False
For pp = Application.Max(Columns("M")) To 1 Step -1
lngZZ = Application.Match(pp, Range(Cells(1, 13), Cells(lngZd, 13)), 0)
Range(Cells(lngZZ, 4), Cells(lngZd, 9)).ClearContents
Range(Cells(lngZZ + 1, 15), Cells(lngZd, 38)).ClearContents
XLPHAN_2
For i = 1 To lngZZ
For j = 15 To 26
If Cells(i, j) <> "" Then
If Cells(i, j).Interior.Color = 52479 Then
If InStr(1, strgSammlung, Format(Cells(i, j), "00"), vbTextCompare) = 0 Then strgSammlung = strgSammlung & "#" & Format(Cells(i, j), "00")
End If
End If
Next j
Next i
If UBound(Split(strgSammlung, "#")) > 0 Then
Cells(lngZZ, 40) = UBound(Split(strgSammlung, "#"))
Else
Cells(lngZZ, 40) = 0
End If
strgSammlung = ""
Next pp
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
Und Du führst nur den letzten Code aus, sonst nichts!!!
Wenn es funktioniert, dann kannst Du die Benennungen der Prozeduren später anpassen.
Wenn irgendwo Select oder Debug.Print auftauchen sollte, diese Zeilen löschen, wenn dann waren sie zu Testzwecken drin.