Opgelost Macro verfijnen "Zoeken naar woord over alle werkbladen"

[tonissteiner]

Hallo,

ik loop vast op een macro waarmee ik op alle werkbladen (met uitzondering van het laatste) wil zoeken naar een bepaald woord en via een message box het aantal weergeef.
Bij mijn eerste poging kwam het resultaat telkens het dubbele uit. Dan dacht ik de oplossing gevonden te hebben door de uitkomst te delen door twee. Maar deze workaround loopt ook verkeerd.
In het testbestandje, als ik in regel 70 "ResultFinal" gebruik en ik gebruik de macro om te zoeken naar bijvoorbeeld Peter of xxx krijg ik de aantallen die juist zijn. Zoek ik dan bijvoorbeeld op het woord failed krijg ik uiteraard een decimaal getal (door de deling door 2) maar klopt het aantal zelfs niet ook. Op Blad1 zou dat (in de kolommen A tot H) 13 keer + op Blad2 1 keer = 14. Als in de code in regel 70 "Result" gebruikt wordt geeft de message box maar 13 weer.

Graag wat hulp waar ik in de mist ga.

Alvast bedankt.

Sub CountCellsWithText()

' Keyboard Shortcut: Ctrl+Shift+C

    Application.EnableEvents = False
    Application.ScreenUpdating = False
 
    Dim CatchPhrase As String
    Dim StrNaam As String
    Dim Result As Double
    Dim R As Range
    Dim I As Integer
    Dim Sheet As Worksheet
    Dim FirstFoundCell As String
    Dim Looped As Boolean
    
    StrNaam = ActiveSheet.Name

    For Each Sheet In ThisWorkbook.Worksheets
            If Sheet.ProtectContents = True Then
               Sheet.Protect Password:="", userinterfaceonly:=True
            End If
    Next
    
    ' Maak alle werkbladen zichtbaar
    For Each Sheet In Worksheets
             Sheet.Visible = True
    Next
    
    ' Op het werkblad blijven waar de zoekfuntie gestart werd
    Worksheets(StrNaam).Activate
    
    Application.ScreenUpdating = True

    CatchPhrase = InputBox("What is the string to match...?", "Advanced search", "Search Item")
    If Not CatchPhrase = "" Then
        findNext = vbYes
        For I = 1 To ActiveWorkbook.Sheets.count - 1    ' De - 1 houdt geen rekening met de laatste drie werkbladen
            If Sheets.Item(I).Visible = xlSheetVisible Then
                Set Sheet = Sheets.Item(I)
                    FirstFoundCell = ""
                    Looped = False
                    Set R = Sheet.Range("A65536")
                    Do While findNext = vbYes And Not Looped
                        Sheets(Sheet.Name).Select
                        Set R = Sheet.Range("A:H").Find(CatchPhrase, R, xlValues, xlPart, xlByRows, xlNext, False)
                    
                        If R Is Nothing Then
                            Exit Do
                    
                            Else
                                If FirstFoundCell = "" Then
                                    FirstFoundCell = R.Address
                                Else
                                    If R.Address = FirstFoundCell Then
                                        Looped = True
                                    End If
                                End If
                            
                            If LCase(R) Like LCase("*" & CatchPhrase & "*") Then
                                Result = Result + 1
                                ResultFinal = Result / 2
                            End If
                        End If
                Loop
            End If
        Next I
    
        If findNext = vbYes Then
            MsgBox "There are " & ResultFinal & " words '" & CatchPhrase & "' found.", vbInformation, "Search Info"
        End If
    End If
    
    ' Terugkeren naar werkblad waar de zoekfuntie gestart werden verberg alle andere werkbladen
    Worksheets(StrNaam).Activate
    
    ' Maak alle werkbladen zichtbaar
    For Each Sheet In Worksheets
        If Sheet.Name <> ActiveSheet.Name Then
           Sheet.Visible = True
        End If
    Next

    Application.EnableEvents = True

End Sub

 

[Enigmasmurf]

Ik heb rap (op macronaam, input- en msgbox na liever van nul begonnen) iets in elkaar gebokst dat vermoedelijk beter zal werken. Werkbladen die je wil uitsluiten mag je zelf nog toevoegen

Sub CountCellsWithText()

woord = InputBox("What is the string to match...?", "Advanced search", "Search Item")
If woord = "" Then Exit Sub
aantal = 0
For Each ws In ThisWorkbook.Worksheets
    Set rng = ws.UsedRange
    If Not rng Is Nothing Then
        For Each cel In rng
            If VarType(cel.Value) = vbString Then
                splits = Split(LCase(cel.Value), LCase(woord))
                If UBound(splits) >= 1 Then
                    cel_aantal = UBound(splits)
                    aantal = aantal + cel_aantal
                End If
            End If
        Next cel
    End If
Next ws
MsgBox "There are " & aantal & " words '" & woord & "' found.", vbInformation, "Search Info"

End Sub

 

[edmoor]

Voorbeeldje met Find en FindNext:

Sub TelWoord()
    Woord = InputBox("Woord", "Zoeken naar")
    If Woord = "" Then Exit Sub
    For i = 1 To Sheets.count - 1
        fa = ""
        With Sheets(i).Range(Sheets(i).UsedRange.Address)
            Set c = .Find(Woord, , xlValues, xlPart, , , False)
            If Not c Is Nothing Then
                Aantal = Aantal + 1
                fa = c.Address
                Set c = .FindNext(c)
                While Not c Is Nothing And c.Address <> fa
                    Aantal = Aantal + 1
                    Set c = .FindNext(c)
                Wend
            End If
        End With
    Next i
    MsgBox Aantal
End Sub

 

[Warme bakkertje]

Geen grote fan van UsedRange aangezien dit tot veel grotere ranges kan leiden dan werkelijk is.

Sub tst()
searchterm = Sheets(1).Range("I1").Value
For j = 1 To Sheets.Count - 1
    lRow = Sheets(j).Cells.Find("*", Sheets(j).[a1], xlFormulas, , xlByRows, xlPrevious).Row
    stext = Sheets(j).Range("A1:H" & lRow).Value
    For I = 1 To UBound(stext)
        For ii = 1 To UBound(stext, 2)
            If stext(I, ii) <> vbNullString Then
                countocc = countocc + UBound(Split(stext(I, ii), searchterm))
            End If
        Next
    Next
Next
MsgBox "There are " & countocc & " words '" & searchterm & "' found.", vbInformation, "Search Info"
End Sub

 

[tonissteiner]

Hallo allen,

je bent blijkbaar bokskampioen Enigmasmurf.
Edmoor en Warme Bakkertje, jullie ook bedankt voor je bijdrage. Ik ga ook wat testen met jullie code om er de inputbox bij te krijgen.
Ik zet de vraag ondertussen wel op opgelost want heb drie mooie oplossingen.

met vriendelijke groeten

 

[edmoor]

Je kan in plaats van Woord = "xxx" in mijn voorbeeld dit gebruiken:

Woord = InputBox("Woord", "Zoeken naar")
If Woord = "" Then Exit Sub

NB:
Aangepast in het voorbeeld van #3.

 

[tonissteiner]

@Warme bakkertje, in jouw code is het van belang of er een hoofdletter gebruikt wordt of niet. Ben even op zoek gegaan hoe ik jouw code kan aanpassen dat er geen rekening gehouden wordt met hoofd of kleine letter maar kon niet meteen iets vinden. Een tip graag ;-)

 

[Warme bakkertje]

Vervang de huidige lijn door deze.

countocc = countocc + UBound(Split(UCase(stext(I, ii)), UCase(searchterm)))

 

[tonissteiner]

Top, nogmaals dikke merci. Ik was aan het proberen in het verkeerde deel van de code. Dacht dat ik het kon oplossen met achter de Find. xlPart bij te voegen of deel van de code te vervangen.

 

[tonissteiner]

@Warme bakkertje, nog een laatste vraag, ik heb deze code gebruikt in een groter bestand met een 30-tal werkbladen echter geeft de code nu fout 2015 op volgende lijn:

If stext(I, iI) <> vbNullString Then

Als ik het bestand reduceer naar bijvoorbeeld vier werkbladen werkt ze nog steeds correct

 

[Warme bakkertje]

Deze foutmelding krijg je hoogstwaarschijnlijk omdat er ergens op een bepaald werkblad een formule een foutwaarde retourneert.
Als de code in Debug gaat kijk dan eens welke waarde de variabele j heeft. dan weet je op welk werkblad de fout voorkomt.

 

[tonissteiner]

@Warme bakkertje: Bedankt voor je tip Rudi. Denk dat ik de fout gevonden heb. Verschillende tabbladen hebben een afbeelding in samengevoegde cellen. Dacht eerst dat het aan de samengestelde cellen lag of verwijzingen naar andere tabbladen. Als ik echter de afbeeldingen verwijder werkt de code perfect.
Zou er aan de code nog iets kunnen toegevoegd worden dat geen rekeningen gehouden wordt met afbeeldingen?

 

[Enigmasmurf]

Samengestelde cellen? De gruwel van elke enigszins Excel-gevorderde. Maar goed, de stelling uit je laatste post leek me zo onwaarschijnlijk dat ik het hier even heb nagebootst, en dat werkt prima. En dat is ook zo met afbeeldingen!
Anderzijds, het idee van Warme bakkertje ("hoogstwaarschijnlijk omdat er ergens op een bepaald werkblad een formule een foutwaarde retourneert") is wél juist.
Mijn eerdere code mag dan een ietsje langer zijn, maar zal in die gevallen ook werken.

Tussen haakjes:
(@edmoor
Ik denk dat je de vraag een beetje anders dan bedoeld hebt ingeschat. Je code telt het aantal cellen waarin het zoekwoord voorkomt i.p.v. het aantal keer.)

 

[tonissteiner]

Dag Enigmasmurf, klopt je code werkt prima ook met samengestelde cellen en afbeeldingen. Echter is het me niet gelukt het uitsluiten van een aantal werkbladen toe te voegen aan je code. Volgens mij zoekt jouw code ook in heel het werkblad. Ik heb ook geprobeerd dit te beperken tot een range maar mijn vba kennis is te beperkt om de code ook hiervoor aan te passen. Sorry

 

[Enigmasmurf]

Ha juist, mijn fout dus, ik had zomaar aangenomen dat je de code uit je openingspost zelf had geschreven en je er daarom wel mee verder zou kunnen.
Probeer dan maar eens hiermee:

Sub CountCellsWithText()

woord = InputBox("What is the string to match...?", "Advanced search", "Search Item")
If woord = "" Then Exit Sub
aantal = 0
For sh = 1 To Sheets.count - 1
  Set ws = Sheets(sh)
  If WorksheetFunction.CountA(ws.Columns("A:H")) > 0 Then
    rij = ws.Columns("A:H").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Set rng = ws.Range("A1:H" & rij)
    For Each cel In rng
      If VarType(cel.Value) = vbString Then
        aantal = aantal + UBound(Split(LCase(cel.Value), LCase(woord)))
      End If
    Next cel
  End If
Next sh
MsgBox "There are " & aantal & " words '" & woord & "' found.", vbInformation, "Search Info"

End Sub

 

[tonissteiner]

Dat is ze volledig, dikke merci