• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

VBA Steekwoorden kleuren in cellen met tekst

Status
Niet open voor verdere reacties.
A

arrie23

Gebruiker
Lid geworden
20 okt 2009
Berichten
400
Beste helpers, helaas kan ik vanuit hier geen attachment invoegen maar hopelijk kan ik mijn probleem duidelijk maken.
Ik heb ergens een macro gevonden die meerdere steekwoorden tegelijk kan kleuren in cellen.
Onderstaande code zoekt binnen cellen (waar naast de steekwoorden nog meer tekst in staat) naar de steekwoorden "auto", "fiets", "trein", "boot", "tram" en kleurt deze specifieke woorden (dus niet de hele cel) vervolgens rood en maakt ze vet.
Deze steekwoorden staan nu hard gecodeerd in het vba-script:

Dim myWords(1 To 5) As String
myWords(1) = "auto"
myWords(2) = "fiets"
myWords(3) = "trein"
myWords(4) = "boot"
myWords(5) = "tram"

Hoe kan ik de code zo aanpassen dat hij verwijst naar een apart tabblad "Steekwoorden" waar in Cel A1 het eerste steekwoord staat, in A2 het tweede steekwoord etc.
Dus in Tabblad "Steekwoorden" Cel A1 staat dan auto, Cel A2 fiets etc.
Ik wil deze steekwoorden kunnen wijzigen (naar bijvoorbeeld "appel", "peer", "perzik" etc.) en het liefst ook dat het bereik van kolom A dynamisch is. Nu van A1:A5 maar bijvoorbeeld ook van A1:A20

Hopelijk voldoende duidelijk. Een alternatieve VBA-oplossing ipv aanpassing van het onderstaande script is uiteraard ook van harte welkom.


Code: 
Sub Steekwoorden_kleuren()
'
' Steekwoorden_kleuren Macro
'
'USE-COLOR AND BOLD TEXT STRINGS WITHIN TEXT EXCEL VBA
     
'************************* DEC VARS *******************************
    Dim myCell As Range
    Dim myRng As Range
    Dim FirstAddress As String
    Dim iCtr As Long
    Dim letCtr As Long
    Dim startrow As Long 'BEGINNING OF RANGE
    Dim endrow As Long ' END OF RANGE
    Dim startcolumn As Integer 'BEGINNING COLUMN
    Dim endcolumn As Integer 'END COLUMN

'************************* SET VALUES*****************************
     
'DUMMY VALUES - COULD BE PASSED
    startrow = 1
    endrow = 65536
    startcolumn = 1
    endcolumn = 10
     
'SET UP RANGE YOU ARE COLORING AND BOLDING -YOU COULD MODIFY TO PASS VALUE TO
    Set myRng = Range(Cells(startrow, startcolumn), Cells(endrow, endcolumn))

    
'HIER MOET VERWEZEN WORDEN NAAR EEN DYNAMISCH BEREIK MET STEEKWOORDEN

    Dim myWords(1 To 5) As String
    myWords(1) = "auto"
    myWords(2) = "fiets"
    myWords(3) = "trein"
    myWords(4) = "boot"
    myWords(5) = "tram"
        
       
     
'BEGIN MASTER LOOP---------------------------------------
    For iCtr = LBound(myWords) To UBound(myWords)
'ERROR FOUND-BYPASS
        On Error Resume Next
        With myRng
            Set myCell = .Find(What:=myWords(iCtr), After:=.Cells(1), _
            LookIn:=xlValues, LookAt:=xlPart, _
            SearchOrder:=xlByRows, _
            SearchDirection:=xlNext, _
            MatchCase:=False)
             'LOGIC CHECK
            If Not myCell Is Nothing Then
                FirstAddress = myCell.Address
                 
                Do
                    For letCtr = 1 To Len(myCell.Value)
                        If StrComp(Mid(myCell.Value, letCtr, _
                        Len(myWords(iCtr))), _
                        myWords(iCtr), vbTextCompare) = 0 Then
                            myCell.Characters(Start:=letCtr, _
                            Length:=Len(myWords(iCtr))) _
                            .Font.ColorIndex = 3
                        End If
                         
                    Next letCtr
                     
                    For letCtr = 1 To Len(myCell.Value)
                        If StrComp(Mid(myCell.Value, letCtr, _
                        Len(myWords(iCtr))), _
                        myWords(iCtr), vbTextCompare) = 0 Then
                            myCell.Characters(Start:=letCtr, _
                            Length:=Len(myWords(iCtr))) _
                            .Font.FontStyle = "Bold"
                        End If
                    Next letCtr
                     
                     'GET NEXT ADDRESS
                    Set myCell = .FindNext(myCell)
                     
                Loop While Not myCell Is Nothing _
                And myCell.Address <> FirstAddress
            End If
        End With
    Next iCtr
        End Sub
 
Laatst bewerkt:
Als je in Blad2 de eerste kolom gebruikt voor de woorden, wijzig dan dit gedeelte:
Code: 
Dim myWords(1 To 5) As String
    myWords(1) = "auto"
    myWords(2) = "fiets"
    myWords(3) = "trein"
    myWords(4) = "boot"
    myWords(5) = "tram"
als volgt:
Code: 
Dim x as integer, myWords(1 To 20) As String
for x = 1 to 20
mywords(x) = Sheets("Blad2").range("A" & x)
next x
 
Beste Zapatr,

Helemaal goed!!:thumb: Enorm bedankt voor je snelle antwoord! Dit scheelt mij weer een heleboel hoofdbrekens :D
 
Mij lijkt dit voldoende:

Code: 
Sub M_snb()
    sn = Sheets("steekwoorden").Cells(1).CurrentRegion.Resize(, 2)
    
    On Error Resume Next
    For j = 1 To UBound(sn)
        Err.Clear
        c01 = Sheet1.Cells.Find(sn(j, 1), , , 2).Address(0, 0)
        If Err.Number = 0 Then
            Do
                sn(j, 2) = sn(j, 2) & "," & c01
                c01 = Sheet1.Cells.Find(sn(j, 1), Range(c01), , 2).Address(0, 0)
                If InStr(sn(j, 2) & ",", "," & c01 & ",") Then Exit Do
            Loop
        End If
    Next
    
    For j = 1 To UBound(sn)
        If sn(j, 2) <> "" Then
           sp = Split(sn(j, 2), ",")
           For jj = 1 To UBound(sp)
              With Sheet1.Range(sp(jj)).Characters(InStr(Sheet1.Range(sp(jj)), sn(j, 1)), Len(sn(j, 1))).Font
                .Bold = True
                .Color = vbRed
              End With
           Next
        End If
    Next
End Sub
 
@snb,
dat de macro in het originele bestand wel erg lang is, was mij ook opgevallen.
Ik heb mij met aanpassingen beperkt tot het gedeelte waar de vragensteller naar vroeg.
 
@zapatr

@Arrie vroeg ook 2 dingen:
- aanpassing van de code (wat jij deed)
- alternatieve code (wat ik deed)

Dus we hebben beide aan Arries verwachtigen voldaan. :D
Aan Arrie (en alle meelezers) de keuze.
 
@snb,
de vraag om een alternatieve code was mij ontgaan, ik zou er trouwens ook niet genoeg tijd voor hebben gehad.
Maar een betere code dan die van jou, zou het toch niet geworden zijn.
 
Beste snb. Bedankt voor je bijdrage!! Fijn dat er maar liefst 2 personen aan mijn verwachtingen voldoen :D
Een alternatieve kortere oplossing is zeker welkom. Zoals gezegd heb ik de oorspronkelijke code ergens gevonden maar als het ook anders/beter/korter kan hou ik me zeker aanbevolen. Ik heb de oplossing van Zapatr aan de praat gekregen maar ik krijg jouw oplossing helaas niet werkend.
Het eerste tabblad ("Sheet1") bevat de cellen met de teksten met daarin de steekwoorden. Tabblad 2 (genaamd "steekwoorden") bevat de steekwoorden. Als ik jouw script uitvoer gebeurt er echter niks: ik krijg geen foutmelding maar de steekwoorden kleuren ook niet.

Helaas is het toevoegen van een bijlage vanuit hier niet mogelijk. Is het teveel gevraagd om een heel klein voorbeeldbestandje waarin jouw script correct draait toe te voegen. Dan krijg ik hem waarschijnlijk wel aangepast op mijn eigen bestand. Alvast bedankt voor je hulp!
 
Beste Wher,

Ook jij bedankt voor je bijdrage! Mooi om te kunnen kiezen voor verschillende oplossingen en bovendien erg leerzaam. Erg fraai dat je zelfs met verschillende kleuren kan werken voor verschillende steekwoorden. Ik zou bij dit voorbeeld echter graag willen dat de letters Cat van Cats ook gekleurd wordt omdat gezocht wordt op Cat. Hij slaat Cats nu over omdat Cats<>Cat.
 
Haha, geweldig! Bedankt allemaal! Ik ben enorm geholpen. Alleen de oplossing van snb heb ik helaas nog niet aan de praat
 
Laatst bewerkt:
Hoi snb, bedankt voor je voorbeeld! Ik heb het toegepast op mijn bestand en jouw script draait nu ook als een zonnetje (en is idd aanzienlijk korter en overzichtelijker dan het oorspronkelijke). Het niet aan de praat krijgen had te maken met Sheet1/Blad1:o
Zapatr, WHER en snb, enorm bedankt voor het meedenken en alle aangedragen oplossingen. In plaats van 1 heb ik nu meerdere oplossingen dus ik ben een rijk man :thumb::D
 
Beste snb, ik was nog wat in de weer met jouw code en hij blijkt voor een goede werking case sensitive te zijn.
Als ik aan jouw bijlage een regeltje in hoofdletters toevoeg met: GEEN BEL EN GEEN AS EROP en ik druk op de knop dan wordt de GEE van GEEN rood gekleurd maar de steekwoorden BEL en AS blijven zwart. Is het mogelijk om de code zo aan te passen dat hij volledig case insensitive is: dat het niet uitmaakt of de steekwoorden in hoofdletters of kleine letters staan en dat het ook niet uitmaakt dat de oorspronkelijke teksten in de cellen in hoofd- of kleine letters staan of zelfs een combinatie daarvan.
 
Kijk eens in de hulpbestanden van de VBEditor (wat je volgens mij al eens gedaan hebt, gezien je reakties in draden van dit forum) en onderzoek welke argumenten meegegeven kunnen worden aan Instr( ... ).

PS. Ik zou internet nooit gebruiken om een VBA 'oplossing' te vinden en volledig over te nemen, doch alleen om op een idee gebracht te worden voor een aanpak/methode die in je eigen code verwerkt kan worden. Internet is nl. vergeven van 'clumsy coding'.
 
Beste snb, bedankt voor je snelle reactie. Ik ga er eens verder mee stoeien. Mijn kennis van VBA beperkt zich momenteel helaas tot het wel kopieren en plakken van idd soms 'clumsy coding' (wat ik overigens lang niet altijd herken als zodanig :o) en daarbinnen slechts hele eenvoudige aanpassingen om het toepasbaar te maken op mijn eigen bestanden. Ik was al wat aan het rommelen met 'Ucase' maar kreeg het nog niet voor elkaar.
 
De aanhouder wint :D. Met behulp van een aantal keer Ucase is de code nu volledig case insensitive. Bedankt voor de hint en nogmaals voor de code.
 
Ik bedoelde iets anders:

Code: 
Sub tst()
    MsgBox InStr(1, "een twee drie vier vijf zes", "Vier", 0)
    MsgBox InStr(1, "een twee drie vier vijf zes", "Vier", 1)
End Sub
 
Aha, vbBinaryCompare versus vbTextCompare. Dat is nog makkelijker dan de Ucase. Het is een leerzaam dagje tot nu toe
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan