Makro zählt falsch

Guten Morgen !
Gestern habe ich ein Makro übers Forum bekommen.
Das Makro sollte einen bestimmten String suchen und mir
eindeutig vorkommende Strings suchen und mir die Anzahl nebendran schreiben.
Funktioniert super, aber zählt nicht richtig.
Makro:
For iCnt = 1 To 30
Set rngF = rng.Find("*s" & iCnt & "*")
If Not rngF Is Nothing Then
wks.Cells(iRow, 1) = "*s" & iCnt & "*"
wks.Cells(iRow, 2) = Application.WorksheetFunktion.CountIf(rng, "=*s" & iCnt & "*")
iRow = iRow + 1
End If
Next
z.B. Bei dem Eintrag in einer Zelle (steht alles in einer Zelle), wie folgt:
on=0271 rn=338310 dw=33831 ns=0 *s8* na=SSB Spezial-Beizerei GmbH *s8* pz=57072 st=Eiserfelderstr. hn=98 *s15* *s15* *s1*
bekomme ich jedes Vorkommnis nur 1 mal als vorhanden angezeigt.
Wer kann helfen ?
M.f.G.
Franz

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub Franz() Dim Pos As Integer, OldPos As Integer, iAnz As Integer For iCnt = 1 To 30 Set rngF = rng.Find("*s" & iCnt & "*") If Not rngF Is Nothing Then wks.Cells(iRow, 1) = "*s" & iCnt & "*" Do OldPos = Pos Pos = InStr(Pos + 1, rng, "*s" & iCnt & "*") If Pos > 0 Then iAnz = iAnz + 1 Loop Until Pos = 0 wks.Cells(iRow, 2) = iAnz iRow = iRow + 1 End If Next iCnt End Sub

Sub suche() Dim wks As Worksheet Dim rng As Range, rngF As Range Dim iCnt As Integer, iRow As Integer Set rng = Sheets(1).UsedRange Set wks = Sheets(3) iRow = 1 For iCnt = 1 To 30 Set rngF = rng.Find("<s" & iCnt & ">") If Not rngF Is Nothing Then wks.Cells(iRow, 1) = "<s" & iCnt & ">" wks.Cells(iRow, 2) = Application.CountIf(rng, "=<s" & iCnt & ">") iRow = iRow + 1 End If Next End Sub

Hallo Franz,
mit der Funktion "ZÄHLENWENN"/"CountIf" wird der gesuchte Wert pro Zelle maximal nur einmal gezählt, auch wenn er in einem Zellinhalt mehrfach vorkommt.
Deshalb habe ich Dein Makro ein wenig modifiziert.
Die sehr vielen Schleifendurchläufe werden sich bei einem größeren Datenbestand natürlich zeitlich bemerkbar machen; bitte deshalb zuerst mit einer kleineren Datenmenge testen.
Ob das Makro nun der Weisheit letzter Schluss ist, weiß ich auch nicht jedenfalls habe ich Deinen Beitrag wieder auf "offen" gestellt. Vielleicht kommen ja noch andere Vorschläge.


Sub suche()
Dim wks As Worksheet
Dim rng As Range, rngF As Range
Dim c As Range
Dim laR As Long
Dim iCnt As Integer, iRow As Integer
Dim Pos As Integer, OldPos As Integer, iAnz As Integer
laR = Sheets(1).Cells(Rows.Count, 10).End(xlUp).Row
Set rng = Sheets(1).Range("J12:J" & laR)
Set wks = Sheets(3)
iRow = 1
For iCnt = 1 To 30
Set rngF = rng.Find("<s" & iCnt & ">")
If Not rngF Is Nothing Then
wks.Cells(iRow, 1) = "<s" & iCnt & ">"
iAnz = 0
For Each c In rng
Pos = 0
Do
OldPos = Pos
Pos = InStr(Pos + 1, c.Text, "<s" & iCnt & ">")
If Pos > 0 Then iAnz = iAnz + 1
Loop Until Pos = 0
Next c
wks.Cells(iRow, 2) = iAnz
iRow = iRow + 1
End If
Next iCnt
Set rngF = Nothing
End Sub

Gruß
WernerB.

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread