Hilfe bei Makro mit CountIf

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub test() Dim LrowA As Long, LrowG As Long, rng As Range, ergebnis As Long 'Daten in Spalte A zuvor per Spezialfilter ohne Duplikate nach Spalte G 'Annahme:Überschriften in erster Zeile 'letzte Zeile in Spalte A LrowA = Cells(Rows.Count, 1).End(xlUp).Row 'letzte Zeile in Spalte G LrowG = Cells(Rows.Count, 7).End(xlUp).Row 'Suchbereich für Formel Set rng = Range("A2:A" & LrowA) 'Anzahl Treffer ergebnis = 0 'Schleife, Ergebnis aufsummieren, bei 3 Treffern For i = LrowG To 2 Step -1 If WorksheetFunction.CountIf(rng, Cells(i, 7)) = 3 Then ergebnis = ergebnis + 1 Next i 'Ausgabe MsgBox ergebnis End Sub

Hallo Peter,
hier was genau für dein Beispiel:


Sub Berechnung1()
Dim lngRow As Long, lngAnz As Long, lngDrei As Long, lngN As Long
Dim arrCountWhat()
' Auslesen der zu suchenenden Daten aus Spalte A 2 bis letzte Zeile.
arrCountWhat = ActiveSheet.Range(Cells(2, 1), Cells(ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row, 1)).Value
' Wenn in A nichts drin dann auch nicht suchen und raus hier.
If UBound(arrCountWhat) <= 0 Then
MsgBox "Nix zum suchen !", vbCritical
Exit Sub
End If
' Alte Zählwerte löschen!
For lngN = LBound(arrCountWhat) To UBound(arrCountWhat)
ActiveSheet.Cells(lngN + 23, 5) = ""
Next lngN
' Und hier nun zählen.
lngRow = 2
Do Until IsEmpty(Cells(lngRow, 7))
For lngN = LBound(arrCountWhat) To UBound(arrCountWhat)
lngAnz = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(lngRow, 8), Cells(lngRow, 17)), arrCountWhat(lngN, 1))
If lngAnz = 3 Then
ActiveSheet.Cells(lngN + 23, 5) = ActiveSheet.Cells(lngN + 23, 5) + 1
Exit For
End If
Next lngN
lngRow = lngRow + 1
Loop
End Sub

Gruß Heiko
PS: Rückmeldung wäre nett !

Sub Berechnung1() Dim lngRow As Long, lngAnz As Long, lngDrei As Long, lngN As Long Dim arrCountWhat() As String ' Wenn in A nichts drin dann auch nicht suchen und raus hier. If ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row = 1 Then MsgBox "Nix zum suchen !", vbCritical Exit Sub End If ' Such Daten einlesen For lngN = 2 To ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row ReDim Preserve arrCountWhat(lngN - 2) arrCountWhat(lngN - 2) = ActiveSheet.Cells(lngN, 1) Next lngN ' Alte Zählwerte löschen! ActiveSheet.Range("E24:E27") = "" ' Und hier nun zählen. lngRow = 2 Do Until IsEmpty(Cells(lngRow, 7)) For lngN = LBound(arrCountWhat) To UBound(arrCountWhat) lngAnz = Application.WorksheetFunction.CountIf(ActiveSheet.Range(Cells(lngRow, 8), Cells(lngRow, 17)), arrCountWhat(lngN)) If lngAnz = 3 Then ActiveSheet.Cells(lngN + 24, 5) = ActiveSheet.Cells(lngN + 24, 5) + 1 Exit For End If Next lngN lngRow = lngRow + 1 Loop End Sub

Beliebteste Forumthreads (12 Monate)

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread