Find Function

[GomaPile]

Hi all, how is everyone doing, it’s been a while since my last post.

Is there someone who’s able to help us that would be super appreciated for our Hospital Uniform Department.

VBA below was found browsing through Google, weblink provided will take you there (it’s safe).

The VBA does what it supposed to do which is find data within the excel, and we did add our bit too.

The VBA is very similar to the build-in FIND FUNCTION that you and I have on all computers today.

Though the difference between the VBA one from Google and build-in FIND FUNCTION both have their Pros & Cons, but we would love to see them All-In-One. Well to be openly 100% honest to everyone, we’re hoping that someone can help us who knows VBA. Anyways, I tried myself – but sadly no luck.

Build-in FIND FUNCTION:

• Pros: goes straight to that cell and cycles through to the next matching info & onwards.
• Cons: doesn’t highlight the cells yellow.

VBA from Google:

• Pros: highlights all matching info in yellow.
• Cons: though it doesn’t go straight to the first cell or cycles through to the next.

Only 3 things we are requesting, if possible, it can be done.

• Highlight all matching cells in Yellow and go to the first highlighted Cell
• The ability to cycle Back and Forth onto the next cell
• Range: only lookup in Columns C and D

'Website https://www.extendoffice.com/documents/excel/5839-excel-search-and-highlight-results.html

Private Sub CommandButton1_Click()

Dim xRg As Range
Dim xFRg As Range
Dim xStrAddress As String
Dim xVrt As Variant

Application.EnableEvents = False
Application.ScreenUpdating = False

Sheets("Orders").Unprotect Password:="test" '---- change the password to your liking's
xVrt = Application.InputBox(prompt:="Search:", Title:="Search Tool...")
If xVrt <> "" Then
Set xFRg = ActiveSheet.Cells.Find(what:=xVrt)
If xFRg Is Nothing Then
MsgBox prompt:="Cannot find this employee", Title:="Search Tool Completed..."
Exit Sub
End If
xStrAddress = xFRg.Address
Set xRg = xFRg
Do
Set xFRg = ActiveSheet.Cells.FindNext(After:=xFRg)
Set xRg = Application.Union(xRg, xFRg)
Loop Until xFRg.Address = xStrAddress
If xRg.Count > 0 Then
xRg.Interior.ColorIndex = 6
If xRsp = vbOK Then xRg.Interior.ColorIndex = xlNone
End If
End If
xRg.Areas(xRg.Areas.Count)(1).Select
Sheets("Orders").Protect Password:="test" '---- change the password to your liking's

Application.ScreenUpdating = True
Application.EnableEvents = True

End Sub

Regards,
Gomapile (NASA2)

 

[Akuini]

Akuini,

I managed to figure it out. You had 2 file extensions xlsm & xlsx added to the file

I can confirm its opened

Cheers

Looks like the extension somehow has changed, it happens sometimes when I download an xlsm file from mediafire.
If you change it back to xlsm the it should be ok.
Now you have the example file, you don't need to recreate the userform from scratch, in vba editor you can just drag & drop the userform to your actual file.

 

[GomaPile]

OMG!! you are amazing. Just had play and you're freaking awesome. I must show this to our Manager's.

Will be speaking to our linen lady tomorrow morning. From what have created I know she will be impressed, for sure!!

Akuini we can't thank you enough for your kind support and service this week for our department. I shall personally recommend you to others in this forum.

Regards
Nasa2 (Gomapile)

 

[Akuini]

OMG!! you are amazing. Just had play and you're freaking awesome. I must show this to our Manager's.

Will be speaking to our linen lady tomorrow morning. From what have created I know she will be impressed, for sure!!

Akuini we can't thank you enough for your kind support and service this week for our department. I shall personally recommend you to others in this forum.

Regards
Nasa2 (Gomapile)

I'm glad you like the code. However, I haven't tested it extensively, so please try it on your actual file and provide some feedback in case there's a bug.

Also, I have wrote another version of the macro, see if it suits you.
The new version:
1. Remove the userform
2. Added: a textbox in the sheet
3. Added: PREV, NEXT & 'Go to Start' BUTTON
4. You search data directly in the sheet via a textbox.

Here's an example of a macro to find and highlight data via a Textbox.
Features:
Partial match search only.
Case-insensitive search only.
Highlights matching cells as you type in the textbox.
If there are no matching data, the textbox will turn red.
Uses Conditional Formatting instead of changing cell interior color, so it won't affect any cell's interior color.
You can navigate through the highlighted cells using the PREV, NEXT & 'Go to Start' BUTTON.
To remove the highlight, press the CLEAR button.
You can use asterix to search, for example: s*h will match Stephanie

Akuini - Live Search & Highlight Data via Textbox #1

MediaFire is a simple to use free service that lets you put all your photos, documents, music, and video in a single place so you can access them anywhere and share them everywhere.

www.mediafire.com

To execute the search only on this specific range: ActiveSheet.Range("B9:K1008"), replace Sub set_Range() with this one:

Sub set_Range()
 
    ' to execute the search only on this specific range
    Set selected_Range = ActiveSheet.Range("B9:K1008")

End Sub

 

[GomaPile]

Akuini,

Just remembered won't be at work tomorrow and won't be able to update the vba changes.

Its my mother's 82nd birthday and we're having a party, sadly this might be her last one

So please forgive me if I don't reply back to your posts. Will do my best to test and provide feedback

Regards,
Nasa2 (Gomapile)

 

[abdelfattah]

Hi Akuini ,
you did really great work so far and you still update this project to getting better result. you're super amazing .
I liked this project .
after you finish from this I suggest for you to write this article alone as the others which your own, until the others members don't find difficulty to got this thread.
best regards,
Abdelfattah

 

[Jaafar Tribak]

Hi Akuini,

I have just finished adding a few functionnalities to your search & highlight utility:

Additions:

1- Small web control showing a little animated search magnifying glass next to the textbox. (I hope this is not a problem accross excel versions)
2- Contexthelp menu (?) on the userform title bar clicking on which displays the info about how the search form works.
3- Checkbox for making the userform client area transparent.
4- Small button for expanding the userform and dynamically picking the highlight color from the color-wheel image. Default highlight color being RGB(253, 250, 55)
5- Your forum icon to the userform.

I had to edit your original code in order to incorporate mine but, also because I run into a few errors specially with the Prev and Next buttons.
The search is however a bit slow specially if the search area is large.

BTW, I have also added a new entry in the ribbon HomeTab so you can call the userform from there.

I hope you like it and if you have any opinions\suggestions or find any bugs, please let me know before I try to make it into an add-in.

Workbook Demo:
Akuini.xlsm





1- This is the api worker code in a Standard Module:

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left   As Long
    Top    As Long
    Right  As Long
    Bottom As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long, ByVal dwNewLong As LongLong) As LongLong
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongLong, ByVal nIndex As Long) As LongLong
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
    #Else
        Private Declare PtrSafe Function SetWindowLong Lib "USER32.DLL" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
        Private Declare PtrSafe Function GetWindowLong Lib "USER32.DLL" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    #End If
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (destination As Any, source As Any, ByVal length As LongPtr)
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare PtrSafe Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare PtrSafe Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GetCursor Lib "user32" () As LongPtr
    Private Declare PtrSafe Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare PtrSafe Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
#Else
  Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hUF As LongPtr) As Long
    Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Private Declare Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As LongPtr, col As Long) As Long
    Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Long, ByVal dwFlags As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function IIDFromString Lib "ole32.dll" (ByVal lpsz As LongPtr, ByVal lpiid As LongPtr) As LongPtr
    Private Declare Function AccessibleObjectFromWindow Lib "OLEACC.DLL" (ByVal hwnd As LongPtr, ByVal dwId As Long, ByVal riid As LongPtr, ppvObject As Any) As Long
    Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal Y As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function GetCursor Lib "user32" () As LongPtr
    Private Declare Function IsWindowEnabled Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Private Declare Function GetDlgItem Lib "user32" (ByVal hDlg As LongPtr, ByVal nIDDlgItem As Long) As LongPtr
#End If


Public Sub AddIcon(ByVal ObjForm As Object)
    Const WM_SETICON = &H80, ICON_SMALL = 0&, ICON_BIG = 1&
    Dim hwnd As LongPtr, hIcon As LongPtr
 
    Call IUnknown_GetWindow(ObjForm, VarPtr(hwnd))
    hIcon = ObjForm.Image1.Picture.Handle
    Call SendMessage(hwnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
    Call SendMessage(hwnd, WM_SETICON, ICON_BIG, ByVal hIcon)
    Call DeleteObject(hIcon)
End Sub

Public Sub AddContextHelp(ByVal oForm As Object)
    Const WS_EX_CONTEXTHELP = &H400, GWL_EXSTYLE = (-20&)
    Dim hwnd As LongPtr
    Call IUnknown_GetWindow(oForm, VarPtr(hwnd))
    Call SetWindowLong(hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_CONTEXTHELP)
End Sub

Public Sub StartContextHelpButtonClickWatcher(ByVal oForm As Object, ByVal bStart As Boolean)
    Dim hwnd As LongPtr
    Call IUnknown_GetWindow(oForm, VarPtr(hwnd))
    If bStart Then
        Call SetProp(hwnd, "Formhwnd", hwnd)
        Call SetTimer(hwnd, hwnd, 0&, AddressOf ContextHelpMonitor)
    Else
        Call KillTimer(GetProp(hwnd, "Formhwnd"), GetProp(hwnd, "Formhwnd"))
    End If
End Sub

Public Sub MakeTransparent(ByVal oForm As Object, ByVal bTrans As Boolean)
    Const GWL_EXSTYLE = (-20&), WS_EX_LAYERED = &H80000, LWA_COLORKEY = &H1, COLOR_BTNFACE = 15&
    Dim hwnd As LongPtr, lWindColor As Long
 
    Call IUnknown_GetWindow(oForm, VarPtr(hwnd))
    If bTrans Then
        Call TranslateColor(GetSysColor(COLOR_BTNFACE), NULL_PTR, lWindColor)
        Call SetWindowLong(hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
        Call SetLayeredWindowAttributes(hwnd, lWindColor, 0&, LWA_COLORKEY)
    Else
        Call SetWindowLong(hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) And Not WS_EX_LAYERED)
    End If
End Sub

Public Sub FormatWBrowser(ByVal Wbr As Object)
    Const COLOR_BTNFACE = 15&
    Dim lWindColor As Long
 
    Call TranslateColor(GetSysColor(COLOR_BTNFACE), NULL_PTR, lWindColor)
    With Wbr
        .Document.body.Scroll = "no"
        .Document.body.bgcolor = lWindColor
        .Document.body.Style.Border = "none"
    End With
End Sub

Public Sub PaintHighlightLabel(ByVal lbl As MSForms.Label)
    Dim tCurPos As POINTAPI, hDC As LongPtr
 
    Call GetCursorPos(tCurPos)
    hDC = GetDC(NULL_PTR)
    lbl.BackColor = GetPixel(hDC, tCurPos.X, tCurPos.Y)
    Call ReleaseDC(NULL_PTR, hDC)
End Sub


' ____________________________________ PRIVATE ROUTINES _________________________________

Private Sub ContextHelpMonitor( _
    ByVal hwnd As LongPtr, _
    ByVal Msg As Long, _
    ByVal idEvent As LongPtr, _
    ByVal dwTime As Long _
)
 
    Static lPrevCur As LongPtr
    Dim hCur As LongPtr
    Dim tHelpButtonRect As RECT, lRet As Long
    Dim tCurPos As POINTAPI
    Dim oiAccTitleBar As IAccessible
    Dim pxLeft As Long, pyTop As Long, pcxWidth As Long, pcyHeight As Long

    On Error GoTo errHandler
    Application.EnableCancelKey = xlDisabled
    If IsVBAError Then
        Debug.Print "Error raised by the Akuini Add-in to prevent crashing!"
        Debug.Print "API timer was safely relased after an unhandled run-time error or a compile error occurred."
     Call KillTimer(idEvent, idEvent): Exit Sub
    End If
    Set oiAccTitleBar = HwndToAcc(idEvent)
    Call oiAccTitleBar.accLocation(pxLeft, pyTop, pcxWidth, pcyHeight, 4&)
    Call SetRect(tHelpButtonRect, pxLeft, pyTop, pxLeft + pcxWidth, pyTop + pcyHeight)
    Call GetCursorPos(tCurPos)
    #If Win64 Then
        Dim lPtr As LongLong
        Call CopyMemory(lPtr, tCurPos, LenB(tCurPos))
        lRet = PtInRect(tHelpButtonRect, lPtr)
    #Else
        lRet = PtInRect(tHelpButtonRect, tCurPos.X, tCurPos.Y)
    #End If
    If lRet Then
        hCur = GetCursor   '
        If hCur <> lPrevCur And lPrevCur <> NULL_PTR Then
            If IsWindowEnabled(idEvent) Then
                UF_Help.Show
                With UF_Finder
                    .CommandButton4.SetFocus
                    .TextBox1.SetFocus
                    .TextBox1.SelStart = Len(.TextBox1)
                End With
            End If
        End If
    End If
    lPrevCur = hCur
    Exit Sub
errHandler:
    If Err.Number <> &HC472& And Err.Number <> 0& Then
        Call KillTimer(idEvent, idEvent)
    End If
End Sub

Private Function HwndToAcc(ByVal hwnd As LongPtr) As IAccessible
    Const ID_ACCESSIBLE As String = "{618736E0-3C3D-11CF-810C-00AA00389B71}"
    Const OBJID_TITLEBAR = &HFFFFFFFE
    Const S_OK = &H0&
    Dim tGUID(0& To 3&) As Long
    Dim oIAc As IAccessible
 
    If IIDFromString(StrPtr(ID_ACCESSIBLE), VarPtr(tGUID(0&))) = S_OK Then
        If AccessibleObjectFromWindow(hwnd, OBJID_TITLEBAR, VarPtr(tGUID(0&)), oIAc) = S_OK Then
           Set HwndToAcc = oIAc
        End If
    End If
End Function

Private Function IsVBAError() As Boolean
    Const GWL_STYLE = (-16&), WS_SYSMENU = &H80000
    Dim sBuffer As String * 256&, sErrPromptText As String, lRet As Long
    Dim hPrompt As LongPtr, lStyle As LongPtr
 
    hPrompt = GetDlgItem(GetActiveWindow, &HFFFF&)
    lRet = GetWindowText(hPrompt, sBuffer, 256&)
    sErrPromptText = VBA.Left(sBuffer, lRet)
    If InStr(1&, sErrPromptText, "compil", vbTextCompare) Or InStr(1&, sErrPromptText, "Kompil", vbTextCompare) Then
        IsVBAError = True
    End If
    lStyle = GetWindowLong(GetActiveWindow, GWL_STYLE)
    If (lStyle And WS_SYSMENU) = 0& Then
        IsVBAError = True
    End If
End Function

-

2- UserForm Module:

Option Explicit

Private xRng As Range, selected_Range As Range
Private txA As String
Private bFormExpanded As Boolean

Private Sub UserForm_Initialize()

    bFormExpanded = False
    CheckBox1.Value = True
    Label4.Caption = ChrW(&HBB)
    Label4.BackColor = RGB(253&, 250&, 55&) '<< default highlight color
    Label7.ForeColor = vbRed
    WebBrowser1.TabStop = False
    Call ActionWebBrowser
    Call AddIcon(Me)
    Call AddContextHelp(Me)
    Call StartContextHelpButtonClickWatcher(Me, True)

    If Selection.Cells.CountLarge = 1& Then
        Set selected_Range = ActiveSheet.UsedRange
    Else
        Set selected_Range = Selection.Cells
    End If

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    If CheckBox1.Value Then Call clear_Format
    Call StartContextHelpButtonClickWatcher(Me, False)
End Sub

Private Sub ActionWebBrowser()
    Dim sGifPath As String
    sGifPath = Environ("temp") & "\Gif_Bytes.gif"
    Call GifFileFromBytes
    Do: DoEvents: Loop Until Len(Dir(sGifPath))
    Me.WebBrowser1.Navigate (sGifPath)
End Sub

Private Sub GifFileFromBytes()
    Dim Bytes() As Byte
    Dim vBytes As Variant
    Dim i As Long, iFileNum As Integer
 
    Dim sPath As String
    sPath = Environ("temp") & "\Gif_Bytes.gif"
 
    If Len(Dir(sPath)) = 0& Then
        vBytes = ThisWorkbook.Worksheets("Gif_Bytes").UsedRange.Value
        ReDim Bytes(LBound(vBytes) To UBound(vBytes))
        For i = LBound(vBytes) To UBound(vBytes)
            Bytes(i) = CByte(vBytes(i, 1&))
        Next
        iFileNum = FreeFile
        Open sPath For Binary As #iFileNum
            Put #iFileNum, 1&, Bytes
        Close iFileNum
    End If
End Sub

Private Sub to_Format()
    Call clear_Format
    With selected_Range
        .FormatConditions.Add Type:=xlTextString, String:=txA, _
        TextOperator:=xlContains
        .FormatConditions(.FormatConditions.Count).SetFirstPriority
        With .FormatConditions(1).Interior
            .PatternColorIndex = xlAutomatic
            .Color = Label4.BackColor  'RGB(Rgb1, Rgb2, Rgb3)
            .TintAndShade = 0
        End With
        .FormatConditions(1).StopIfTrue = False
    End With
End Sub

Private Sub clear_Format()
    Dim fc As FormatCondition
    For Each fc In ActiveSheet.Cells.FormatConditions
        If fc.Type = xlTextString Then
'       If fc.Interior.Color = RGB(Rgb1, Rgb2, Rgb3) Then
            If fc.Priority = 1& Then
                fc.Delete
                Exit For
            End If
        End If
    Next fc
End Sub

Private Sub to_label(a As Long)
    With Me.Label1
    If a = 1 Then
        .Caption = "Find What: "
        .ForeColor = vbBlack
    Else
        .Caption = "Nothing found"
        .ForeColor = vbRed
        Beep
    End If
    End With
End Sub

Private Sub CommandButton1_Click()
    'FIND ALL BUTTON
    Dim c As Range
    Dim sAddress As String
 
    'txA = LCase(TextBox1.Text)
    If txA = "" Then Exit Sub
    'clear_Format
    Set xRng = Nothing
    With selected_Range
        Set c = .Find(What:=txA, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not c Is Nothing Then
            Set xRng = c
            sAddress = c.Address
            Do
               Set c = .FindNext(c)
               Set xRng = Union(xRng, c)
            Loop While Not c Is Nothing And c.Address <> sAddress
            to_label (1)
        Else
            to_label (2)
        End If
    End With
    If Not xRng Is Nothing Then
        xRng.Activate
    End If
End Sub

Private Sub CommandButton2_Click()
    'PREV BUTTON
    Dim c As Range
 
    Call StartContextHelpButtonClickWatcher(Me, False)
    If txA = "" Then Exit Sub
        Set c = Cells.Find(What:=txA, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious, MatchCase:=False, SearchFormat:=False)
        If Not c Is Nothing Then
            c.Activate
            to_label (1)
        Else
            to_label (2)
        End If
    Call StartContextHelpButtonClickWatcher(Me, True)

End Sub

Private Sub CommandButton3_Click()
    'NEXT BUTTON
    Dim c As Range
 
    Call StartContextHelpButtonClickWatcher(Me, False)
    If txA = "" Then Exit Sub
        Set c = Cells.Find(What:=txA, After:=ActiveCell, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not c Is Nothing Then
            c.Activate
            to_label (1)
        Else
            to_label (2)
        End If
    Call StartContextHelpButtonClickWatcher(Me, True)

End Sub

Private Sub CheckBox2_Click()
    If CBool(CheckBox2.Value) Then
        TextBox1.BackColor = &HFF99FF
    Else
        TextBox1.BackColor = &HFFFFFF
    End If
    Call MakeTransparent(Me, CBool(CheckBox2.Value))
    TextBox1.SetFocus
End Sub

Private Sub Label2_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Call PaintHighlightLabel(Label4)
    If Len(TextBox1) Then
        Call to_Format
    End If
End Sub

Private Sub Label4_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Me.Width = IIf(bFormExpanded, 216&, 375&)
    Label4.Caption = IIf(bFormExpanded, ChrW(&HBB), ChrW(&HAB))
    bFormExpanded = Not bFormExpanded
End Sub

Private Sub Label4_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Me.Width = IIf(bFormExpanded, 216&, 375&)
    Label4.Caption = IIf(bFormExpanded, ChrW(&HBB), ChrW(&HAB))
    bFormExpanded = Not bFormExpanded
End Sub

Private Sub CommandButton4_Click()
    Unload Me
End Sub

Private Sub TextBox1_Change()

    Dim c As Range, xRng2 As Range
    Dim sAddress As String

    txA = Trim(TextBox1.Text)
    If txA <> "" Then
        Call to_Format
    Else
        Call clear_Format
    End If
    to_label (1)

    If txA = "" Then Me.Label7 = "": Exit Sub
    Set xRng2 = Nothing
    With selected_Range
        Set c = .Find(What:=txA, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not c Is Nothing Then
            Set xRng2 = c
            sAddress = c.Address
            Do
                Set c = .FindNext(c)
                Set xRng2 = Union(xRng2, c)
            Loop While Not c Is Nothing And c.Address <> sAddress
            Me.Label7 = "[" & xRng2.Cells.Count & "]" & " Cells."
        Else
            Me.Label7 = ""
        End If
    End With

End Sub

Private Sub WebBrowser1_NavigateComplete2(ByVal pDisp As Object, URL As Variant)
    Call FormatWBrowser(WebBrowser1)
End Sub

Ribbon XML

<customUI xmlns="http://schemas.microsoft.com/office/2009/07/customui">
    <ribbon startFromScratch="false">
        <tabs>
            <tab idMso="TabHome">
                <group id="customGroup" label="Akuini Cell Finder" insertAfterMso="GroupEditingExcel">
                    <button id="customButton" label="Run" image="Akuini" size="large" screentip=" " supertip="Find Text And Highlight Cells" onAction="Callback" />
                </group>
            </tab>
        </tabs>
    </ribbon>
</customUI>

Edit:
I hope I am not mistaken but I think you don't really need to stick to the CF RGB(253, 250, 55) because you are setting the priority (SetFirstPriority) so when clearing, you just need to check against those CF with priority #1 If fc.Priority = 1&

 

[Akuini]

I had to edit your original code in order to incorporate mine but, also because I run into a few errors specially with the Prev and Next buttons.

First of all, WOW, your work is pretty impressive! I really like the color picker.
Feel free to change my code anyway you want, it's your project now.


I can see that you count the matching words; however, as you said,

The search is however a bit slow specially if the search area is large.

I tested it on about 6000 cells with data, and after typing "a" in the textbox, the iteration in TextBox1_Change took about 13 seconds.

So here's my suggestion: let's limit the iteration to, say, 200 max. I did it like this:

Private Sub TextBox1_Change()

    Dim c As Range, xRng2 As Range
    Dim sAddress As String

    txA = Trim(TextBox1.Text)
    If txA <> "" Then
        Call to_Format
    Else
        Call clear_Format
    End If
    to_label (1)

    If txA = "" Then Me.Label7 = "": Exit Sub
    Set xRng2 = Nothing
    With selected_Range
        Set c = .Find(What:=txA, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
        If Not c Is Nothing Then
            Set xRng2 = c
            sAddress = c.Address
             t = Timer

            Do
                Set c = .FindNext(c)
                Set xRng2 = Union(xRng2, c)
            
            'max 200 iteration
            qq = qq + 1
            If qq = 200 Then
                tx = "At least : "

                Exit Do
            End If
            
            
            Loop While Not c Is Nothing And c.Address <> sAddress
            Application.StatusBar = "It's done in:  " & Format(Timer - t, "0.00") & " seconds"
            Debug.Print "It's done in:  " & Format(Timer - t, "0.00") & " seconds"
               Me.Label7 = tx & "[" & xRng2.Cells.Count & "]" & " Cells."
        Else
            Me.Label7 = ""
        End If
    End With

End Sub

With this change, it only took 0.2 seconds!

I hope I am not mistaken but I think you don't really need to stick to the CF RGB(253, 250, 55) because you are setting the priority (SetFirstPriority) so when clearing, you just need to check against those CF with priority #1 If fc.Priority = 1&

That's a good point.

One thing, though—you don't have to put my name on the userform or in the ribbon. Instead, put your name on it. If you continue developing this as an add-in, you can put my name in the ABOUT section as a co-author."

Note: I made a few changes for clarity and added punctuation marks to enhance the flow of the text. However, if there were specific code snippets or technical details in the original text that needed correction, I couldn't address them without further context.

Noted.

One more thing, today I just learned from YouTube how to insert a button into the Ribbon via XML; it turned out it's not that difficult. So, I will probably incorporate my code into my add-in called "Search deList." Well, it may not be as good as yours, but it will be a nice addition to the Search deList add-in

 

[Akuini]

Hi Akuini ,
you did really great work so far and you still update this project to getting better result. you're super amazing .
I liked this project .
after you finish from this I suggest for you to write this article alone as the others which your own, until the others members don't find difficulty to got this thread.
best regards,
Abdelfattah

I'm glad you like it & thanks for your kind words. As you can see in the previous post, I had discussions with @Jaafar Tribak about developing this into an add-in.

 

[GomaPile]

Hey Akuini, how are you?

Firstly, we would like to again knowledge your great excel skills. We/Department have decided to start using the workbook called: Akuini - Find & Highlight via Userform #2 file.

Feedback:

• It's simple and productive way for looking up info within your database.
• Very user-friendly for any staff to use or for training purposes.
• The fine/search function is ideal for our department especially with the hospital busy activity.
• Navigating forward (NEXT) or backward (PREVIOUS) has minimise the workload a lot.
• And also, having the data highlight yellow as you type has made it easy on the eyes not having to scroll through pages of data.
• Excellent Work!!!

After reading some of the other posts I'm surprised to see so many replies from my first original post.
Jaafar, when I do find the time, we would like to review yours at a later date looks very interesting.

Have a great weekend to all.

Kind Regards,
Nasa2

 

[Akuini]

Hey Akuini, how are you?

I'm doing fine, and I hope you and your family are doing well too. I'm glad that the macro is useful for you and your colleagues. In fact, I've decided to incorporate the macro into an add-in that I've created called 'Search deList.' I will probably share it in a few days.

In the add-in, I will insert some buttons in the ribbon to execute the 'Find & Highlight' macro, so you can navigate through the highlighted cells using those buttons. This way, you won't need buttons in your sheets anymore.

I need more information:
Are you going to use this macro in just one file, with specific need i.e. to work only in specific range (B9:K1008)? Or will it be used in multiple files?

Search deList add-in:

I created an Excel add-in called “Search deList”, to create searchable data validation

I created an add-in called “Search deList”, and I share it as a freeware. Its function is to speed up searching in data validation list. In any cell that has data validation (with List type) pressing ALT+RIGHT will open a Userform with a combobox. You can type multiple keywords (separated by a...

www.mrexcel.com