Excel Vba Color And Bold

Hvis du vil fremhæve bestemte navne eller ord i en eller flere EXCEL-søjler/rækker kan denne VBA-kode gøre det:

1. Excel > Alt-F11 for at åbne VBA

2. "Insert" —> "Module".

3. Du har nu et åbent, tomt kodevindue, kopier følgende tekstblok fra og med "sub" til og med "end sub" linierne

4. Man arbejder i hele aktuelle ark. Under SET VALUES kan du vælge, hvilke søjler/rækker teksten skal fremhæves i

5. Under myWords = Array("aba", "cat" etc.) - slet indhold i parentes og skriv de(t) ord, der ønskes fremhævet omgivet af "". Hvis siden er "frosset", skal selve regnearket blot gemmes, så virker denne funktion igen.

6. Vælg farve for fremhævet tekst: .Font.ColorIndex = , alm. værdier:
Sort: 1; Hvid (på farvet baggrund): 2; Rød: 3, Grøn: 4, Blå: 5; Gul: 6
Alle mulige farver: http://dmcritchie.mvps.org/excel/colors.htm

7. Vælg font-type: **.Font.FontStyle = **, alm. værdier: "Plain", "Bold", "Italic"

Sub ColorandBold()
     'USE-COLOR AND BOLD TEXT STRINGS WITHIN TEXT EXCEL VBA
     'BROUGHT TO YOU BY WWW.PROGRAMMINGLIBRARY.COM
     'CREATED BY MARK SLOBODA

     '************************* 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 = 10000
    startcolumn = 1
    endcolumn = 200

     'SET UP RANGE YOU ARE COLORING AND BOLDING -YOU COULD MODIFY TO PASS VALUE TO
    Set myRng = Range(Cells(startrow, startcolumn), Cells(endrow, endcolumn))

     'SET UP ARRAY WITH WORDS YOU WANT TO COLOR AND BOLD - YOU COULD PUSH VALUES FROM A LISTBOX TO THIS ARRAY
    myWords = Array("dog", "cat", "hamster")

     '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 = 5
                        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 = "Plain"
                        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
Medmindre andet er angivet, er indholdet af denne side licenseret under Creative Commons Attribution-ShareAlike 3.0 License