VBA for text search in active sheet and change its format

B

banglong

New Member
Joined
Mar 11, 2016
Messages
17
Office Version
  1. 365
  2. 2019
Platform
  1. Windows
Hi,

I need your help to use VBA code to search a text in a current workbook and change the format of that find text. My workbook have many sheet. The example as attachment.

Thanks in advance.
 

Attachments

  • EXCEL.png
    EXCEL.png
    17.3 KB · Views: 6

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
Sort by date Sort by votes
hI
Give this code a try
VBA Code: 
Sub test()
    Dim Rng As Range, cl As Range, POS, POS2 As Integer, i As Long
    Dim a As Variant
    Dim SH As Worksheet
    On Error Resume Next
    a = Split(InputBox("TYPE SEACHSTRING SPERATE BY A COMA ,"), ",")
    For Each SH In ThisWorkbook.Sheets
        With SH
            For i = 0 To UBound(a)
                Set Rng = .Range("B2").CurrentRegion
                For Each cl In Rng
                    POS = InStr(1, cl, a(i), vbTextCompare)
                    Do Until POS = 0
                        With cl.Characters(POS, Len(a(i)))
                            If i = 0 Then
                                .Font.Bold = True
                            Else
                                .Font.Italic = True
                            End If
                        End With
                        POS = InStr(POS + 1, cl, a(i), vbTextCompare)
                    Loop
                Next cl
            Next
        End With
    Next
End Sub
 
Upvote 0
mohadin said:
hI
Give this code a try
VBA Code: 
Sub test()
    Dim Rng As Range, cl As Range, POS, POS2 As Integer, i As Long
    Dim a As Variant
    Dim SH As Worksheet
    On Error Resume Next
    a = Split(InputBox("TYPE SEACHSTRING SPERATE BY A COMA ,"), ",")
    For Each SH In ThisWorkbook.Sheets
        With SH
            For i = 0 To UBound(a)
                Set Rng = .Range("B2").CurrentRegion
                For Each cl In Rng
                    POS = InStr(1, cl, a(i), vbTextCompare)
                    Do Until POS = 0
                        With cl.Characters(POS, Len(a(i)))
                            If i = 0 Then
                                .Font.Bold = True
                            Else
                                .Font.Italic = True
                            End If
                        End With
                        POS = InStr(POS + 1, cl, a(i), vbTextCompare)
                    Loop
                Next cl
            Next
        End With
    Next
End Sub
Click to expand...
This code work properly if my find text start at cell B2. How about if this text located in various column and row. Hope you can help on this. Thanks so much.
 
Upvote 0
TRy
VBA Code: 
Sub test()
    Dim Rng As Range, cl As Range, POS As Integer, i As Long
    Dim a As Variant
    Dim SH As Worksheet
    On Error Resume Next
    a = Split(InputBox("TYPE SEACHSTRING SPERATE BY A COMA ,"), ",")
    For Each SH In ThisWorkbook.Sheets
        With SH
            Dim FCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set FCell = .Cells(.Cells.Find("*", _
                                                                   .Cells(.Rows.Count, .Columns.Count)).Row, .Cells.Find("*", _
                                                                                                                         .Cells(.Rows.Count, .Columns.Count), , , 2).Column)
            Dim LCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set LCell = .Cells(.Cells.Find("*", , , , 1, 2) _
                                                      .Row, .Cells.Find("*", , , , 2, 2).Column)
                                                  Set Rng = Range(FCell.Address, LCell.Address)
                                                      
            For i = 0 To UBound(a)
                For Each cl In Rng
                    POS = InStr(1, cl, a(i), vbTextCompare)
                    Do Until POS = 0
                        With cl.Characters(POS, Len(a(i)))
                            If i = 0 Then
                                .Font.Bold = True
                            Else
                                .Font.Italic = True
                            End If
                        End With
                        POS = InStr(POS + 1, cl, a(i), vbTextCompare)
                    Loop
                Next cl
            Next
        End With
    Next
End Sub
 
Upvote 0
It
mohadin said:
TRy
VBA Code: 
Sub test()
    Dim Rng As Range, cl As Range, POS As Integer, i As Long
    Dim a As Variant
    Dim SH As Worksheet
    On Error Resume Next
    a = Split(InputBox("TYPE SEACHSTRING SPERATE BY A COMA ,"), ",")
    For Each SH In ThisWorkbook.Sheets
        With SH
            Dim FCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set FCell = .Cells(.Cells.Find("*", _
                                                                   .Cells(.Rows.Count, .Columns.Count)).Row, .Cells.Find("*", _
                                                                                                                         .Cells(.Rows.Count, .Columns.Count), , , 2).Column)
            Dim LCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set LCell = .Cells(.Cells.Find("*", , , , 1, 2) _
                                                      .Row, .Cells.Find("*", , , , 2, 2).Column)
                                                  Set Rng = Range(FCell.Address, LCell.Address)
                                                    
            For i = 0 To UBound(a)
                For Each cl In Rng
                    POS = InStr(1, cl, a(i), vbTextCompare)
                    Do Until POS = 0
                        With cl.Characters(POS, Len(a(i)))
                            If i = 0 Then
                                .Font.Bold = True
                            Else
                                .Font.Italic = True
                            End If
                        End With
                        POS = InStr(POS + 1, cl, a(i), vbTextCompare)
                    Loop
                Next cl
            Next
        End With
    Next
End Sub
Click to expand...
It works in current worksheet only. The others ws not aplied. Im still need ur help if this code can do for all ws. Thanks in advance.
 
Upvote 0
Sorry
Me bad
one missing period
VBA Code: 
Sub test()
    Dim Rng As Range, cl As Range, POS As Integer, i As Long
    Dim a As Variant
    Dim SH As Worksheet
    On Error Resume Next
    a = Split(InputBox("TYPE SEACHSTRING SPERATE BY A COMA ,"), ",")
    For Each SH In ThisWorkbook.Sheets
        With SH
            Dim FCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set FCell = .Cells(.Cells.Find("*", _
                                                              .Cells(.Rows.Count, .Columns.Count)).Row, .Cells.Find("*", _
                                                                                                                    .Cells(.Rows.Count, .Columns.Count), , , 2).Column)
            Dim LCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set LCell = .Cells(.Cells.Find("*", , , , 1, 2) _
                                                  .Row, .Cells.Find("*", , , , 2, 2).Column)
            Set Rng = .Range(FCell.Address, LCell.Address)

            For i = 0 To UBound(a)
                For Each cl In Rng
                    POS = InStr(1, cl, a(i), vbTextCompare)
                    Do Until POS = 0
                        With cl.Characters(POS, Len(a(i)))
                            If i = 0 Then
                                .Font.Bold = True
                            Else
                                .Font.Italic = True
                            End If
                        End With
                        POS = InStr(POS + 1, cl, a(i), vbTextCompare)
                    Loop
                Next cl
            Next
        End With
    Next
End Sub
 
Upvote 0
Solution
mohadin said:
Sorry
Me bad
one missing period
VBA Code: 
Sub test()
    Dim Rng As Range, cl As Range, POS As Integer, i As Long
    Dim a As Variant
    Dim SH As Worksheet
    On Error Resume Next
    a = Split(InputBox("TYPE SEACHSTRING SPERATE BY A COMA ,"), ",")
    For Each SH In ThisWorkbook.Sheets
        With SH
            Dim FCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set FCell = .Cells(.Cells.Find("*", _
                                                              .Cells(.Rows.Count, .Columns.Count)).Row, .Cells.Find("*", _
                                                                                                                    .Cells(.Rows.Count, .Columns.Count), , , 2).Column)
            Dim LCell As Range
            If Not .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), -4123, , 1) _
               Is Nothing Then Set LCell = .Cells(.Cells.Find("*", , , , 1, 2) _
                                                  .Row, .Cells.Find("*", , , , 2, 2).Column)
            Set Rng = .Range(FCell.Address, LCell.Address)

            For i = 0 To UBound(a)
                For Each cl In Rng
                    POS = InStr(1, cl, a(i), vbTextCompare)
                    Do Until POS = 0
                        With cl.Characters(POS, Len(a(i)))
                            If i = 0 Then
                                .Font.Bold = True
                            Else
                                .Font.Italic = True
                            End If
                        End With
                        POS = InStr(POS + 1, cl, a(i), vbTextCompare)
                    Loop
                Next cl
            Next
        End With
    Next
End Sub
Click to expand...
Great works. Big thanks for u.
 
Upvote 0
You are welcome
And thank you for the feedback
Be happy & safe
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Solved
Concatenate Text To Populate 'Customer ID' Box
Replies
8
Views
359
Kerryx
K
S
  • Solved
Find Text in a cell
Replies
5
Views
130
Fluff
Fluff
T
  • Solved
Copy worksheet to new workbook without formulas or macro button
Replies
9
Views
541
Tgrundy09
T
O
  • Solved
mod(row() change font colour as required
Replies
7
Views
237
Peter_SSs
Peter_SSs
G
  • Solved
Dynamic Button for Email Macro
Replies
4
Views
210
GarnesGambit
G

Forum statistics

Threads
1,214,808
Messages
6,121,686
Members
449,048
Latest member
81jamesacct

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top