nachfolgende Zellen bei bestimmten Auslöser zählen

Hallo Zusammen,
ich habe bei einem VBA Makro ein Problem, bei dem ich nicht weiterkomme. Vielleicht kann mir hier jemand weiterhelfen ?!
Ich habe in Tabelle4 bestimmte Einträge.
Tabelle4
A5: AAAAA
A6: BBBBB
A7: CCCCC
A8: DDDDD
A9: EEEEE
Für jeden dieser Einträge soll in Tabelle1 gezählt werden:
Der Auslöser für das Starten des Zählens soll der unterstrichene, fett markierte Eintrag in Tabelle1 die Spalte A sein.
Alle nachfolgenden Einträge sollen solange gezählt werden, bis ein anderer unterstrichener, fett markierter Eintrag kommt.
Tabelle1:
A1: AAAAA
A2: AAAAA
A3: AAAAA
A4: BBBBB
A5: BBBBB
A6: BBBBB
A7: EEEEE
A8: BBBBB
A9: BBBBB
A10: BBBBB
A11: AAAAA
A12: AAAAA
A13: CCCCC
A14: AAAAA
A15: CCCCC
A16: CCCCC
A17: CCCCC
A18: DDDDD
A19: DDDDD
A20: BBBBB
A21: BBBBB
A22: BBBBB
A23: EEEEE
A24: BBBBB
A25: BBBBB
A26: BBBBB
Anschließend soll pro Eintrag a) der Höchstwert des Zählens und b) die Gesamtanzahl ausgeben werden. Sollte dann so aussehen:
           max     Gesamt
AAAAA   2           3
BBBBB   6          10
CCCCC   2           2
DDDDD 1           1
EEEEE    0           0
Leider scheitere ich schon daran, die Gesamtanzahl zählen zu lassen. Wenn der Eintrag ein zweites Mal vorkommt, müsste der Bereich für das Zählen ein anderer sein. Das bekomme ich aber nicht hin.


Sub Makro()
Dim Bereich As Range
Dim Auswahl As Integer
Dim Zelle    As Range
Dim Zellen    As Range
Dim weg As Range
Dim Anzahl As Long
Dim Name As Variant
Set Bereich = Worksheets("Tabelle1").Range("A1:A26")
Auswahl = 5
For Each Zellen In Worksheets("Tabelle4").Range("A5:A9")
Name = Worksheets("Tabelle4").Cells(Auswahl, 1).Value
For Each Zelle In Bereich
If Zelle = Name And Zelle.Font.Bold = True Then
For Each weg In Bereich
If weg  Name And weg.Font.Bold = False And weg.Font.Underline = -4142 Then
Anzahl = Anzahl + 1
ElseIf weg = Name And weg.Font.Bold = False And weg.Font.Underline = 2
Then
Anzahl = Anzahl + 1
ElseIf weg = Name And weg.Font.Bold = True And weg.Font.Underline = 2
Then
Anzahl = Anzahl
ElseIf weg  Name And weg.Font.Bold = True And weg.Font.Underline = 2
Then
Exit For
End If
Next weg
End If
Next Zelle
MsgBox Name & " Gesamt:  " & Anzahl
Auswahl = Auswahl + 1
Anzahl = 0
Next Zellen
End Sub

Wäre super wenn mir jemand helfen könnte.
Danke

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Makro() Dim o As Object, w As Variant Dim a&(1 To 2), bo As Variant, z&, zmax&, boxer$ zmax = Range("A" & Rows.Count).End(xlUp).Row If zmax 25 Then Stop If Range("A" & z).Font.Bold Or z = zmax + 1 Then If o.exists(boxer) Then bo = o(boxer) bo(1) = bo(1) + a(1) If bo(2) "Dummy" Then Range("D" & z) = w bo = o(w) Range("E" & z) = bo(2) Range("F" & z) = bo(1) z = z + 1 End If Next End Sub

Hi Matthias
Gibt sicher noch Optimierungsmöglichkeiten, aber probier mal...
Sub Mach()
Dim WS1 As Worksheet, WS2 As Worksheet
Dim findeZeile As Long, lMax As Long
Dim i As Long
Set WS1 = Worksheets("Daten")
Set WS2 = Worksheets("Ergebnis")
WS2.Cells.Delete
For i = 1 To WS1.Range("A65536").End(xlUp).Row
If WS1.Cells(i, 1).Font.Bold = True Then
If WorksheetFunction.CountIf(WS2.Columns(1), WS1.Cells(i, 1)) = 0 Then
findeZeile = WS2.Range("A65536").End(xlUp).Row + 1
WS2.Cells(findeZeile, 1) = WS1.Cells(i, 1)
WS2.Cells(findeZeile, 2) = 0
WS2.Cells(findeZeile, 3) = 0
End If
Else
findeZeile = Application.Match(WS1.Cells(i, 1), WS2.Columns(1), 0)
WS2.Cells(findeZeile, 3) = WS2.Cells(findeZeile, 3) + 1
lMax = checkMax(i, WS1)
If lMax > WS2.Cells(findeZeile, 2) Then WS2.Cells(findeZeile, 2) = lMax
End If
Next i
End Sub

Private Function checkMax(i As Long, WS1 As Worksheet) As Long
Dim x As Long
checkMax = 1
x = i
Do While WS1.Cells(x, 1) = WS1.Cells(x + 1, 1)
checkMax = checkMax + 1
x = x + 1
Loop
End Function

cu
Chris

Sub Makro() Dim vergleichsListe As Range Dim Zeile As Integer Dim Zelle As Range Dim Zellen As Range Dim istName As Range Dim Anzahl As Long Dim Name As Variant Dim ws1 As Worksheet Dim isChange As Boolean Dim i As Integer i = 1 Set ws1 = Sheets("Tabelle4") Worksheets("Tabelle4").Range("B5:C9").Value = vbNullString Set vergleichsListe = Worksheets("Tabelle1").Range("A1:A26") Zeile = 5 For Each Zellen In Worksheets("Tabelle4").Range("A5:A9") Name = Zellen.Value isChange = False For Each Zelle In vergleichsListe If Zelle = Name And Zelle.Font.Bold = True Then For Each istName In vergleichsListe If istName Name And istName.Font.Bold = False And istName.Font.Underline = - _ 4142 And Not isChange Then Anzahl = Anzahl + 1 ElseIf istName = Name And istName.Font.Bold = False And istName.Font.Underline = _ 2 Then Anzahl = Anzahl + 1 isChange = False ElseIf istName Name And istName.Font.Bold = True And istName.Font. _ Underline = 2 Then If ws1.Cells(Zeile, 2).Value vbNullString Then If Anzahl > ws1.Cells(Zeile, 2).Value Then ws1.Cells(Zeile, 2).Value = Anzahl ws1.Cells(Zeile, 3).Value = ws1.Cells(Zeile, 3).Value + Anzahl Else ws1.Cells(Zeile, 3).Value = ws1.Cells(Zeile, 3).Value + Anzahl End If isChange = True Anzahl = 0 Else ws1.Cells(Zeile, 2).Value = Anzahl ws1.Cells(Zeile, 3).Value = Anzahl Anzahl = 0 isChange = True End If End If Next If Anzahl > 0 Then If Anzahl > ws1.Cells(Zeile, 2).Value Then ws1.Cells(Zeile, 2).Value = Anzahl ws1.Cells(Zeile, 3).Value = ws1.Cells(Zeile, 3).Value + Anzahl Else ws1.Cells(Zeile, 3).Value = ws1.Cells(Zeile, 3).Value + Anzahl End If End If Exit For

Beliebteste Forumthreads (12 Monate)

nachfolgende Zellen bei bestimmten Auslöser zählen

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

323 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

nachfolgende Zellen bei bestimmten Auslöser zählen

8 Beiträge zum Forumthread Beiträge zu diesem Forumthread

323 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

8
Beiträge zum Forumthread

Beiträge zu diesem Forumthread