Hilfe bei Makro mit CountIf

Forumthread: Hilfe bei Makro mit CountIf

17.10.2006 19:42:42

Peter

Hallo Forum,
ich möchte mit einer Schleife alle Artikel welche dreifach vorkommen zählen.
Die zu zählenden Artikel stehen in Spalte 1.
Wer kann helfen?
-siehe Beispieldatei-
https://www.herber.de/bbs/user/37468.xls
Vielen Dank im voraus
Peter

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Hilfe bei Makro mit CountIf

18.10.2006 08:08:46

Harald
AW: Hilfe bei Makro mit CountIf

18.10.2006 08:22:52

Heiko
Neue Version

18.10.2006 08:42:35

Heiko

AW: Hilfe bei Makro mit CountIf

18.10.2006 08:08:46

Harald

Hallo Peter,
ohne mir die Mappe anzusehen, hab ich mal ein Bsp gebastelt.


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

Gruss Harald

AW: Hilfe bei Makro mit CountIf

18.10.2006 08:22:52

Heiko

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 !

Neue Version

18.10.2006 08:42:35

Heiko

Hallo Peter,
wenn dann auch richtig, hier die stabilere Version:


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

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

Beliebteste Forumthreads (12 Monate)

Forumthread: Hilfe bei Makro mit CountIf

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

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread