VBA code for search in active sheet with user input

[irfan dedrani]

I wanted code for search in my active sheet with user input box and I have 30 sheets I don't want to see loop vise I can select which sheet data I have to search

 

[cmowla]

Hi.

• This is the first time I've been here in about a year. I actually spent a lot of time making something like this for a previous client of mine, and it is very involved to get it to handle BIG DATA.
• There may be a better way to code this, but this implementation runs fast and works reliably for a very large amount of data.
• The way the following code works is, when you search for a term/phrase, and it's found, it will filter out all rows in an Excel Table (Overview of Excel tables (one with filters, coloring, etc.) that do not have it.
• The rows that remain have that search item in them somewhere (in at least one of the columns). Sometimes it's hard to find which column it's in, but it's definitely in one (or more) of them!
• It has a Search button and a Show All Rows button (both of which . . . and much more) that I give you the convenience of renaming (all in the first code block, as you will see soon).
• And as I mention in the first code block (comments for you to read, code/words for you to change if you will), part of the code creates a button in a custom toolbar in the Add-ins ribbon and/or adds these two buttons/selections to your right-click context menu. So in that way, the search bar can search every sheet independently as you desire.
• Should you wish to do a cumulative search, after you search once, just search again without clicking on Show All Rows. But if you don't want to do a cumulative search, then click Show All Rows after you search.
• A search in one sheet is independent of all other 29 sheets you have. You can Show All Rows later (leave rows filtered out), if you wish. It doesn't matter. (As long as there is just ONE Excel table in each sheet.)
• It doesn't matter if you don't have the top-left of the table at cell [A1] either. The Excel Table object can be offset anywhere on the sheet.

It's just important that there is only ONE Excel Table object in the active sheet you wish to search/filter out rows. Just in case you are not aware of what those are (highly doubtful . . . 30 sheets? Wow, that's intense!), to convert an Excel spreadsheet to a table (these have existed at least since Excel 2007),

1. Select the entire table's contents (Ctrl A). If it's not a continuous range, be sure to manually select from the top-left corner to the bottom-right corner!
2. Press Ctrl T and follow the prompt and click okay.
3. You can format the table the way you like it at the top of the window somewhere.

Okay, here's the code (but still more for you to read in this first code block). Feel free to put all of it in the same (standard) VBA code module. But this first bit are short functions for you to change the name of all moving parts (if desired). Just copy all of what's in this code block into the same code module (and put the remaining code blocks in the same one also. I just split the code into 2 parts, because I wanted to show you the code you need to read the surrouding comments and/or make changes to the naming convention. The second code block is LONG and is the heart of the code. It is not something you need to read/understand, but I have tests for each subroutine and sufficient comments.).

Option Explicit

'This assumes that there is only ONE Excel Table object in the active sheet!
    'To convert an Excel spreadsheet to a table,
    '[1] select the entire table's contents.
    '[2] Press Ctrl T and follow the prompt and click okay.

'Change these two conditions for the search type (if desired).
Function Case_Sensitive()
Case_Sensitive = False
End Function

Function Match_Entire_Cell_Contents()
Match_Entire_Cell_Contents = False
End Function


'This followng 2 line sub will create a toolbar in the Add-ins ribbon so
'that you can search any active sheet in the Excel Workbook.
'Pass True if you also want to be able to access the search
'from right-clicking on a cell in a sheet, in addition to
'the toolbar.
Sub Test__Main_Toolbar_And_Right_Click_Menu()
Call Main_Toolbar_And_Right_Click_Menu(False) 'Creates toolbar in Add-ins ribbon.
Call Main_Toolbar_And_Right_Click_Menu(True) 'Creates right click menu items
End Sub
'(You can choose either (or both) venues for the search bar.
'But if you want them both, keep them in this order)!

'As I will mention in the second code block, the two lines above that begin with Call need to put put in Private Sub Workbook_Open(),
'because it will be lost every time you close the Workbook otherwise (and you will have to come
'to the code window and manually "initialize" it for the day)!  But more on that later.

'Now, the menu items buttons "Search" and "Show All Rows" will after when you run the above Sub, Test__Main_Toolbar_And_Right_Click_Menu.
'But you can change the name of these buttons right here:
Function Unfilter_Table_Button_Name()
Unfilter_Table_Button_Name = "Show All Rows"
End Function

Function Search_Button_Name()
Search_Button_Name = "Search"
End Function

'You may also modify the text in the search bar here.
Function Search_Bar()
Dim title As String, message As String, MyInput As String

title = "(Press [ENTER] when finished.)"

message = "Type in a word or phrase. (NOT case-sensitive)"


MyInput = InputBox(message, title, "")
If MyInput <> "" Then Search_Bar = MyInput
End Function


'And if what you search for happens to be on every row in the table,
'this is the message you will receive.  Feel free to change it here.
Function Every_Row_Contained_The_Search()
Every_Row_Contained_The_Search = "Every row contains the search phrase somewhere.  (No rows were filtered.)"
End Function

'And of course, if what you search for was not found,
Function Search_Was_Not_Found()
Search_Was_Not_Found = "The term/phrase was not found in this Excel sheet."
End Function

'And if you don't want this to pop up (it should take a few seconds for the
'search to finish anyway) should what you search for not be found,
'just set this = False.
Function Tell_Me_That_There_Was_No_Results()
Tell_Me_That_There_Was_No_Results = True
End Function

'Lastly, change the name of this toolbar if you wish, but it's not necessary.
'It has to be named something.
Function Irfan_Dedranis_Toolbar_Name()
Irfan_Dedranis_Toolbar_Name = "Irfan Dedranis Toolbar 01"
End Function

So from the above, I mentioned to do this for the ThisWorkbook module. Double click on it

And copy and paste the following code in it. (Remove one of the Call statements if you don't like what it does.)

Private Sub Workbook_Open()
Call Main_Toolbar_And_Right_Click_Menu(False) 'Creates toolbar in Add-ins ribbon.
Call Main_Toolbar_And_Right_Click_Menu(True) 'Creates right click menu items
End Sub

And here is the remaining code to put in the standard code module with (after) the code that you put in from the first code block. It's a ridiculous amount of code (I program a function/sub that does one thing and thus my code tends to look like this. But again, this is for BIG DATA. It's fast, and it's surprisingly bug free:

'-------------------Code Begins Now------------------------
'No need to view it.  Just be aware that it will create   '
'(and use) a sheet named "RngComplementSht".  But it will '
'be hidden (out of your way).                             '
'----------------------------------------------------------
Sub Test__ToolBarExists()
MsgBox ToolBarExists(Irfan_Dedranis_Toolbar_Name)
End Sub
Function ToolBarExists(strName As String) As Boolean
Dim tlbar As CommandBar
For Each tlbar In Application.CommandBars
    If tlbar.Name = strName Then
        ToolBarExists = True
        Exit For
    End If
Next tlbar
End Function
Sub Delete_This_Specific_Toolbar(toolbarName As String)
'For the sole purpose of this editor, we delete the previously existing toolbars in Add-ins before we create them again.  (For debugging,coding.)
'Code is from https://stackoverflow.com/questions/35866915/vba-remove-custom-toolbar-from-ribbon-excel-2002
Dim CB As Office.CommandBar
For Each CB In CommandBars
    On Error Resume Next
    If Not CB.BuiltIn Then
        If CB.Name = toolbarName Then CB.Delete
    Else
        CB.Reset
    End If
Next CB
End Sub
Sub DeleteFromCellMenu()
'Set custom context (right click) menu items.
'First clear any that were set before (so that there is no duplicates!)
Dim ctrl As CommandBarControl, ContextMenu As CommandBar
Set ContextMenu = Application.CommandBars("List Range Popup")
For Each ctrl In ContextMenu.Controls
    If ctrl.Tag = "My_Cell_Control_Tag" Then ctrl.Delete
Next ctrl

'And a note from, https://stackoverflow.com/a/22670092
    'When right-clicking in a "normal" cell the CommandBars("Cell") menu is used.
    'When right-clicking in a Table the CommandBars("List Range Popup") menu is used.

End Sub
Sub Main_Toolbar_And_Right_Click_Menu(rightClickMenu As Boolean)

Dim irfan_Dedranis_Toolbar As CommandBar
Dim Sub_Menu_Level_01 As CommandBarControl

'-------------------------------
'Toolbar/right-click menu object
'-------------------------------
If rightClickMenu = True Then
    Call DeleteFromCellMenu
    'https://stackoverflow.com/a/22670092
    'When right-clicking in a "normal" cell the CommandBars("Cell") menu is used.
    'When right-clicking in a Table the CommandBars("List Range Popup") menu is used.
    Set irfan_Dedranis_Toolbar = Application.CommandBars("List Range Popup")
Else
    If ToolBarExists(Irfan_Dedranis_Toolbar_Name) Then Call Delete_This_Specific_Toolbar(Irfan_Dedranis_Toolbar_Name)
    Set irfan_Dedranis_Toolbar = CommandBars.Add(Name:=Irfan_Dedranis_Toolbar_Name, position:=msoBarTop, MenuBar:=True, Temporary:=False)
    irfan_Dedranis_Toolbar.Protection = msoBarNoMove
    irfan_Dedranis_Toolbar.Visible = True
End If

'Menu Item
If rightClickMenu = True Then
    Set Sub_Menu_Level_01 = irfan_Dedranis_Toolbar.Controls.Add(Type:=msoControlButton, Before:=2)
Else
    Set Sub_Menu_Level_01 = irfan_Dedranis_Toolbar.Controls.Add(Type:=msoControlButton)
End If
With Sub_Menu_Level_01
   .Caption = Search_Button_Name
   .Style = msoButtonIconAndCaption
   .FaceId = 109
   .OnAction = "Search_Bar_Runner"
   If rightClickMenu = True Then .Tag = "My_Cell_Control_Tag"
End With

'Menu Item
If rightClickMenu = True Then
    Set Sub_Menu_Level_01 = irfan_Dedranis_Toolbar.Controls.Add(Type:=msoControlButton, Before:=3)
Else
    Set Sub_Menu_Level_01 = irfan_Dedranis_Toolbar.Controls.Add(Type:=msoControlButton)
End If
With Sub_Menu_Level_01
   .Caption = Unfilter_Table_Button_Name
   .Style = msoButtonIconAndCaption
   .FaceId = 135
   .OnAction = "Clear_Filters_Of_All_Columns_In_Excel_Table"
   If rightClickMenu = True Then .Tag = "My_Cell_Control_Tag"
End With

End Sub
Sub Clear_Filters_Of_All_Columns_In_Excel_Table()
'Assumes that there is just one Excel table in the active sheet.
With ActiveSheet
    'Lift all filters
    .ListObjects(1).AutoFilter.ShowAllData

    'If per chance there are hidden rows from the search (or something else), unhide them.
    .usedRange.EntireRow.Hidden = False
End With

End Sub


Sub Search_Bar_Runner()

Dim rng As Range
Set rng = ActiveSheet.ListObjects(1).DataBodyRange

Dim firstDataRow As Long
firstDataRow = rng(1).Row

Dim lastDataRow As Long
lastDataRow = firstDataRow + rng.Rows.Count - 1

Dim firstDataColumn As Integer
firstDataColumn = rng(1).Column

If Filter_Rows(ActiveSheet.Name, firstDataRow, lastDataRow, rng.address, Search_Bar, Case_Sensitive, Match_Entire_Cell_Contents) = False Then
    'Do nothing
Else
    Cells(firstDataRow, firstDataColumn).Select
End If

End Sub
Function Filter_Rows(sheetName As String, firstDataRow As Long, lastDataRow As Long, _
searchRange As String, search As String, caseSensitive As Boolean, matchEntireCellContents As Boolean)

If Trim(search) = "" Then GoTo Nothing_Found

Dim look_At_This As Variant
If matchEntireCellContents = True Then
    look_At_This = xlWhole
Else
    look_At_This = xlPart
End If

Dim FoundCell As Range, myRange As Range, LastCell As Range
Set myRange = Sheets(sheetName).Range(searchRange)

'By default, the Range.Find feature will start searching from the beginning once it's at the end.
'So to guarantee that the search starts at the beginning, make the start cell to search the last cell in the search range.
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(What:=search, after:=LastCell, SearchDirection:=xlNext, MatchCase:=caseSensitive, LookIn:=xlValues, lookat:=look_At_This, SearchOrder:=xlByRows)

'See if anything was found
If Not FoundCell Is Nothing Then
    Filter_Rows = True
    Dim rangeWithOccurrences As Range

    'Mark the first occurrence so that we can use it to terminate the loop.
    Dim firstOccurrenceAddress As String
    firstOccurrenceAddress = FoundCell.address

    Dim FirstOccurrence As Range
    Set FirstOccurrence = FoundCell

    'But there may be only one occurrence.
    Set FoundCell = myRange.Find(What:=search, after:=FoundCell, SearchDirection:=xlNext, MatchCase:=caseSensitive, LookIn:=xlValues, lookat:=look_At_This, SearchOrder:=xlByRows)
    If FoundCell.address = firstOccurrenceAddress Then
        'If so then quit searching.
        Set rangeWithOccurrences = FoundCell
        GoTo Done
    Else
        'Otherwise, continue searching.
        'Note that we needed the above intermediate step because of the terminating condition in the loop!
        'And note that we did NOT add the FirstOccurrence to the Union, because by default, the loop will terminate (and record) the first occurrence.
        'This way one does not have to remove a duplicate first occurrence from the Union/collection.
    End If
   
    '(We go through the above trouble to reduce the number of assignments -- and elliminate a conditional -- in the body of the loop below.)
   
    Set rangeWithOccurrences = FoundCell
    Do Until FoundCell.address = firstOccurrenceAddress
        Set FoundCell = myRange.Find(What:=search, after:=FoundCell, SearchDirection:=xlNext, MatchCase:=caseSensitive, LookIn:=xlValues, lookat:=look_At_This, SearchOrder:=xlByRows)
        Set rangeWithOccurrences = Union(rangeWithOccurrences, FoundCell)
    Loop
Else
    GoTo Nothing_Found
End If

Done:

Dim complement_Address As String
complement_Address = ComplementOfBrokenUpRangeAddress(firstDataRow, lastDataRow, rangeWithOccurrences.address)

'If there is at least one row in the complement (which we are to hide),
If complement_Address <> "0" Then
    Sheets(sheetName).Range(complement_Address).EntireRow.Hidden = True
Else
    MsgBox Every_Row_Contained_The_Search, , "Search Bar"
End If

Exit Function
Nothing_Found:
If Tell_Me_That_There_Was_No_Results = True Then
    If search <> "" Then MsgBox Search_Was_Not_Found & vbNewLine & vbNewLine & Chr(34) & search & Chr(34), , "Search Bar"
End If
Filter_Rows = False

End Function


Sub Test__ComplementOfBrokenUpRangeAddress()

'Tests for sheets which don't have an EXCEL TABLE.
Debug.Print ComplementOfBrokenUpRangeAddress(1, 53, "A3:B12,D14:F30,F32:F32")
Debug.Print ComplementOfBrokenUpRangeAddress(1, 1048576, "A3:B12,D14:F30,F31:F31")
Debug.Print ComplementOfBrokenUpRangeAddress(5, 21, "4:21")
Debug.Print ComplementOfBrokenUpRangeAddress(7, 312, "$M$290,$C$311:$C$312,$C$7")

'Four cases when there is just one area.  (These test cases cover all possibilities.)  They are written in the form:  (firsDataRow,lastDataRow,rangeAddress)
'1,55,"3:25" --> "1:2,26:55"
'1,25,"3:25" --> "1:2"   OR   1,15,"3:25"   --> "1:2"
'3,55,"3:25" --> "26:55"   OR  22,55,"3:25" --> "26:55"
'3,25,"3:25" --> 0  OR  5,25,"3:25" --> 0   OR  3,21,"3:25" --> 0  OR  5,21,"3:25" --> 0

End Sub
Function ComplementOfBrokenUpRangeAddress(firstDataRow As Long, lastDataRow As Long, rngAddress As String) As String

'-------------------------------------------------------------------------------------------------------------------------
'The following process will consoidate "A3:B12,D14:F30,F31:F31", for example, to "3:12,14:32", WHICH WE NEED for the loop!
'-------------------------------------------------------------------------------------------------------------------------
    Dim rangeAddress As String
    rangeAddress = rngAddress
   
    'Remove all letters from a range.
    rangeAddress = Convert_Letter_Areas_To_Row_Areas(rangeAddress)
   
    'Re-introduce letters for ALL areas in the range, but just make them the same letter, say, A.
    rangeAddress = Replace(rangeAddress, ":", ":A")
    rangeAddress = Replace(rangeAddress, ",", ",A")
    rangeAddress = "A" & rangeAddress
 
    '(Doing the above will handle ALL inputs.  Some inputs are "1:3", others are "A1:C3", for example.)
   
    'If a range has more than one area (and thus may possibily need to be consolidated),
    If (InStr(rangeAddress, ",") > 0) And (InStr(rangeAddress, ":") > 0) Then
        'It's redundant in a way, but Union() -- the function we will use to consolidate -- requires two or more arguments.
        'We can choose any cell address in rangeAddress to Union with rangeAddress to not change rangeaddress.
        'Let's just choose the first one.
        'Ex.
        'Debug.Print Union(Range("A3"), Range("A3:B12,D14:F30,F31:F31")).address
        Dim firstCellAddress As String
        firstCellAddress = SubString(rangeAddress, 1, InStr(rangeAddress, ":") - 1)
        rangeAddress = Union(Range(firstCellAddress), Range(rangeAddress)).address
    End If
    rangeAddress = Replace(rangeAddress, "A", "")
    rangeAddress = Replace(rangeAddress, "$", "")

'Now begin.
Dim numberOfAreas As Integer
numberOfAreas = Number_Of_Occurrences(rangeAddress, ",") + 1

Dim lowerbound As Long
Dim upperbound As Long

If numberOfAreas = 1 Then
    ReDim groupsOfVisibleRows(0 To 0) As String
    groupsOfVisibleRows(0) = rangeAddress
Else
    ReDim groupsOfVisibleRows(1 To numberOfAreas - 1) As String
    groupsOfVisibleRows = Split(rangeAddress, ",") 'Split makes an array with starting index of 0.
End If

'If there is a single row such as "31:31", it is (unfortunately) written as "31".  So MAKE IT "31:31"!!!!!
Dim i As Long
i = 0
Do While i <= numberOfAreas - 1
    If InStr(groupsOfVisibleRows(i), ":") = 0 Then groupsOfVisibleRows(i) = groupsOfVisibleRows(i) & ":" & groupsOfVisibleRows(i)
    i = i + 1
Loop

'--------------------------------------------------------------------------------
'It's possible that we have an input like "$M$290,$C$311:$C$312,$C$7".
'At this point, we would have Join(groupsOfVisibleRows) == "290:290,311:312,7:7".
'But clearly the FINAL areas are OUT OF ORDER.
'We NEED them to be in order.
'So order them.
'--------------------------------------------------------------------------------
If numberOfAreas = 1 Then GoTo Begin_Loop

rangeAddress = Sort_Row_Address_In_Ascending_Order(Join(groupsOfVisibleRows, ","))

'We have to parse the string into an array again.
ReDim groupsOfVisibleRows(1 To numberOfAreas - 1) As String
groupsOfVisibleRows = Split(rangeAddress, ",")

Begin_Loop:
'Now begin the loop.
Dim complement_Address As String
complement_Address = ""

'Initial upperbound
upperbound = SubString(groupsOfVisibleRows(0), InStr(groupsOfVisibleRows(0), ":") + 1, Len(groupsOfVisibleRows(0)))
i = 1
Do While i <= numberOfAreas - 1
    lowerbound = SubString(groupsOfVisibleRows(i), 1, InStr(groupsOfVisibleRows(i), ":") - 1)
    'Debug.Print groupsOfVisibleRows(i)
    'Debug.Print "{" & upperbound & "," & lowerbound & "}"
    complement_Address = complement_Address & upperbound + 1 & ":" & lowerbound - 1 & ","
    upperbound = SubString(groupsOfVisibleRows(i), InStr(groupsOfVisibleRows(i), ":") + 1, Len(groupsOfVisibleRows(i)))
    i = i + 1
Loop

ComplementOfBrokenUpRangeAddress = SubString(complement_Address, 1, Len(complement_Address) - 1)

'Possible Prepend
    Dim initialLowerBound As Long
    initialLowerBound = SubString(groupsOfVisibleRows(0), 1, InStr(groupsOfVisibleRows(0), ":") - 1)
    'Debug.Print initialLowerBound
    If firstDataRow < initialLowerBound Then ComplementOfBrokenUpRangeAddress = firstDataRow & ":" & initialLowerBound - 1 & "," & ComplementOfBrokenUpRangeAddress

'Possible Append (if the current = the largest/last upperbound is < lastDataRow),
    If upperbound < lastDataRow Then ComplementOfBrokenUpRangeAddress = ComplementOfBrokenUpRangeAddress & "," & upperbound + 1 & ":" & lastDataRow

'If it was just one area, then its possible that:

    'An extra comma is prepended if there is just one area.
    If Left(ComplementOfBrokenUpRangeAddress, 1) = "," Then ComplementOfBrokenUpRangeAddress = Right(ComplementOfBrokenUpRangeAddress, Len(ComplementOfBrokenUpRangeAddress) - 1)
   
    'An extra comma is appended if there is just one area.
    If Right(ComplementOfBrokenUpRangeAddress, 1) = "," Then ComplementOfBrokenUpRangeAddress = Left(ComplementOfBrokenUpRangeAddress, Len(ComplementOfBrokenUpRangeAddress) - 1)

    'Two commas to exist in the output.
    ComplementOfBrokenUpRangeAddress = Replace(ComplementOfBrokenUpRangeAddress, ",,", ",")
   
    ComplementOfBrokenUpRangeAddress = Remove_Range_Areas_Where_The_Row_Number_To_The_Left_Of_The_Column_Is_Larger(ComplementOfBrokenUpRangeAddress)
   
If ComplementOfBrokenUpRangeAddress = "" Then ComplementOfBrokenUpRangeAddress = 0

End Function

Sub Test__Sort_Row_Address_In_Ascending_Order()
Debug.Print Sort_Row_Address_In_Ascending_Order("314:320,311:312,7:7")
End Sub
Function Sort_Row_Address_In_Ascending_Order(rangeAddress As String)

Dim numberOfAreas As Integer
numberOfAreas = Number_Of_Occurrences(rangeAddress, ",") + 1

If numberOfAreas = 1 Then
    Sort_Row_Address_In_Ascending_Order = rangeAddress
    Exit Function
End If

'Create a hidden sheet that we will use for sorting.
    'Just in case the user has multiple workbooks opened and happens to select another at this time!
    ThisWorkbook.Activate

    Dim activeSheetName As String
    activeSheetName = ActiveSheet.Name
   
    If WorksheetExists("RngComplementSht") = False Then
        Worksheets.Add after:=Sheets(activeSheetName)
        ActiveSheet.Name = "RngComplementSht"
        'ActiveSheet.Visible = xlSheetVeryHidden
    Else
        Sheets("RngComplementSht").Cells.ClearContents
    End If
   
    Dim previousEvents As Boolean
    previousEvents = Application.EnableEvents
    Application.EnableEvents = False
    Sheets(activeSheetName).Select
    Application.EnableEvents = previousEvents

ReDim groupsOfVisibleRows(1 To numberOfAreas - 1) As String
groupsOfVisibleRows = Split(rangeAddress, ",") 'Split makes an array with starting index of 0.

With Sheets("RngComplementSht")
    .Cells(1, 1).EntireColumn.NumberFormat = "General" 'good for integers.
    .Cells(1, 2).EntireColumn.NumberFormat = "@" 'It may write them as DATES!!!
   
    'Put the arguments of the array in the sheet.
    Application.Calculation = xlCalculationManual
    Dim i As Long
    i = 0
    Do While i <= numberOfAreas - 1
        .Cells(i + 1, 1).Value = SubString(groupsOfVisibleRows(i), 1, InStr(groupsOfVisibleRows(i), ":") - 1)
        .Cells(i + 1, 2).Value = groupsOfVisibleRows(i)
        i = i + 1
    Loop
    Application.Calculation = xlCalculationAutomatic
    'Sort just that portion of the sheet by column A (the numbers).
    Call Sort_Acending_Rectanglular_Range(.Name, "A1:A" & numberOfAreas, "A1:B" & numberOfAreas)

    Dim newRangeAddress As String
    newRangeAddress = ""
   
    'Collect the sorted values from the sheet into a string.
    i = 0
    Do While i <= numberOfAreas - 1
        newRangeAddress = newRangeAddress & .Cells(i + 1, 2) & ","
        i = i + 1
    Loop
   
    'Remove the last (unneeded) comma.
    newRangeAddress = Left(newRangeAddress, Len(newRangeAddress) - 1)

End With

Sort_Row_Address_In_Ascending_Order = newRangeAddress

End Function
Function WorksheetExists(sSheet As String) As Boolean
On Error Resume Next
WorksheetExists = ThisWorkbook.Sheets(sSheet).index
End Function
Sub Test__SortACustomRectangeRange()
Call Sort_Acending_Rectanglular_Range(ActiveSheet.Name, "A1:A3", "A1:B3")
End Sub
Sub Sort_Acending_Rectanglular_Range(sheetName As String, sortColumAddress As String, sortRangeAddress As String)
With Sheets(sheetName).Sort
    .SortFields.Clear
    .SortFields.Add2 Key:=Range(sortColumAddress), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    .SetRange Range(sortRangeAddress)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With
End Sub


Sub Test__Convert_Letter_Areas_To_Row_Areas()
Dim address As String
address = "$A$8:$C$27,$E$8:$E$27,$G$8:$G$27,$I$8:$K$27,$M$8:$N$27,$A$62:$C$64,$E$62:$E$64,$G$62:$G$64,$I$62:$K$64,$M$62:$N$64,$A$66:$C$70,$E$66:$E$70,$G$66:$G$70,$I$66:$K$70,$M$66:$N$70,$A$76:$C$76,$E$76,$G$76,$I$76:$K$76,$M$76:$N$76"
'MsgBox Convert_Letter_Areas_To_Row_Areas(address)
MsgBox Convert_Letter_Areas_To_Row_Areas("8:27,62:64,66:70,76:76")
End Sub
Function Convert_Letter_Areas_To_Row_Areas(addr As String)

Dim rowAddress As String
rowAddress = Replace(addr, "A", "")
rowAddress = Replace(rowAddress, "B", "")
rowAddress = Replace(rowAddress, "C", "")
rowAddress = Replace(rowAddress, "D", "")
rowAddress = Replace(rowAddress, "E", "")
rowAddress = Replace(rowAddress, "F", "")
rowAddress = Replace(rowAddress, "G", "")
rowAddress = Replace(rowAddress, "H", "")
rowAddress = Replace(rowAddress, "I", "")
rowAddress = Replace(rowAddress, "J", "")
rowAddress = Replace(rowAddress, "K", "")
rowAddress = Replace(rowAddress, "L", "")
rowAddress = Replace(rowAddress, "M", "")
rowAddress = Replace(rowAddress, "N", "")
rowAddress = Replace(rowAddress, "O", "")
rowAddress = Replace(rowAddress, "P", "")
rowAddress = Replace(rowAddress, "Q", "")
rowAddress = Replace(rowAddress, "R", "")
rowAddress = Replace(rowAddress, "S", "")
rowAddress = Replace(rowAddress, "T", "")
rowAddress = Replace(rowAddress, "U", "")
rowAddress = Replace(rowAddress, "V", "")
rowAddress = Replace(rowAddress, "W", "")
rowAddress = Replace(rowAddress, "X", "")
rowAddress = Replace(rowAddress, "Y", "")
rowAddress = Replace(rowAddress, "Z", "")
rowAddress = Replace(rowAddress, "$", "")

Convert_Letter_Areas_To_Row_Areas = rowAddress

End Function


Sub Test__Remove_Range_Areas_Where_The_Row_Number_To_The_Left_Of_The_Column_Is_Larger()
MsgBox Remove_Range_Areas_Where_The_Row_Number_To_The_Left_Of_The_Column_Is_Larger("7:18,20:18,20:110")
End Sub
Function Remove_Range_Areas_Where_The_Row_Number_To_The_Left_Of_The_Column_Is_Larger(rangeAddress As String)
Dim listOfAreas() As String
listOfAreas = Split(rangeAddress, ",")

Dim leftNumber As Long, rightNumber As Long, finalAddress As String
finalAddress = ""

Dim i As Integer
i = LBound(listOfAreas)
Do While i <= UBound(listOfAreas)
    leftNumber = SubString(listOfAreas(i), 1, InStr(listOfAreas(i), ":") - 1)
    rightNumber = SubString(listOfAreas(i), InStr(listOfAreas(i), ":") + 1, Len(listOfAreas(i)))
    If leftNumber <= rightNumber Then finalAddress = finalAddress & "," & listOfAreas(i)
    i = i + 1
Loop

If SubString(finalAddress, 1, 1) = "," Then finalAddress = SubString(finalAddress, 2, Len(finalAddress))
Remove_Range_Areas_Where_The_Row_Number_To_The_Left_Of_The_Column_Is_Larger = finalAddress

End Function


Sub Test__SubString()
MsgBox SubString("ABCDEF", 3, 5)
End Sub
Function SubString(str As String, start As Long, finish As Long)
On Error Resume Next
SubString = Mid(str, start, finish - start + 1)
End Function


Sub Test__Number_Of_Occurrences()
MsgBox Number_Of_Occurrences("xx^2+6x+9", "x")
End Sub
Function Number_Of_Occurrences(expression As String, character As String)
Number_Of_Occurrences = (Len(expression) - Len(Replace(expression, character, ""))) / Len(character)
End Function


Sub Test__Print_Array()
Call Print_Array(Split("a,b,c,1,2,3", ","))
End Sub
Sub Print_Array(arr As Variant)
Dim index As Integer
Debug.Print "--------------------"
For index = LBound(arr) To UBound(arr)
    Debug.Print arr(index), index
Next index
Debug.Print "--------------------"
End Sub

 

[mumps]

Do you want the macro to prompt you to enter the search criteria and for the desired sheet name? What do you want to do when you find the search term?

 

[cmowla]

What do you want to do when you find the search term?

That's a good question. Because in my fourth bullet point, I mention that my search bar code will filter out the rows that don't contain the search, but I didn't mention that it will highlight the cells (well color . . . conditional formatting can slow down the Workbook significantly with 30 sheets) that contain the search to make it easier.

So if this is what is desired, here are modifications of some of the existing subroutines, as well as some new ones.

The modified Filter_Rows sub so that it also highlights the cells with the search. (There are 8 new lines of code in this sub. All of which end with a ***.)

Function Filter_Rows(sheetName As String, firstDataRow As Long, lastDataRow As Long, _
searchRange As String, search As String, caseSensitive As Boolean, matchEntireCellContents As Boolean)

If Trim(search) = "" Then GoTo Nothing_Found

Dim look_At_This As Variant
If matchEntireCellContents = True Then
    look_At_This = xlWhole
Else
    look_At_This = xlPart
End If

Dim FoundCell As Range, myRange As Range, LastCell As Range
Set myRange = Sheets(sheetName).Range(searchRange)

'By default, the Range.Find feature will start searching from the beginning once it's at the end.
'So to guarantee that the search starts at the beginning, make the start cell to search the last cell in the search range.
Set LastCell = myRange.Cells(myRange.Cells.Count)
Set FoundCell = myRange.Find(What:=search, after:=LastCell, SearchDirection:=xlNext, MatchCase:=caseSensitive, LookIn:=xlValues, lookat:=look_At_This, SearchOrder:=xlByRows)

'See if anything was found
If Not FoundCell Is Nothing Then
    Filter_Rows = True
    Dim rangeWithOccurrences As Range

    'Mark the first occurrence so that we can use it to terminate the loop.
    Dim firstOccurrenceAddress As String
    firstOccurrenceAddress = FoundCell.address

    Dim FirstOccurrence As Range
    Set FirstOccurrence = FoundCell

    'But there may be only one occurrence.
    Set FoundCell = myRange.Find(What:=search, after:=FoundCell, SearchDirection:=xlNext, MatchCase:=caseSensitive, LookIn:=xlValues, lookat:=look_At_This, SearchOrder:=xlByRows)
    If FoundCell.address = firstOccurrenceAddress Then
        'If so then quit searching.
        Set rangeWithOccurrences = FoundCell
        GoTo Done
    Else
        'Otherwise, continue searching.
        'Note that we needed the above intermediate step because of the terminating condition in the loop!
        'And note that we did NOT add the FirstOccurrence to the Union, because by default, the loop will terminate (and record) the first occurrence.
        'This way one does not have to remove a duplicate first occurrence from the Union/collection.
    End If
   
    '(We go through the above trouble to reduce the number of assignments -- and elliminate a conditional -- in the body of the loop below.)
    Dim foundCellAddresses As String '***
    foundCellAddresses = Replace(FoundCell.address, "$", "") '***
    Set rangeWithOccurrences = FoundCell
    Do Until FoundCell.address = firstOccurrenceAddress
        Set FoundCell = myRange.Find(What:=search, after:=FoundCell, SearchDirection:=xlNext, MatchCase:=caseSensitive, LookIn:=xlValues, lookat:=look_At_This, SearchOrder:=xlByRows)
        foundCellAddresses = foundCellAddresses & "," & Replace(FoundCell.address, "$", "") '***
        Set rangeWithOccurrences = Union(rangeWithOccurrences, FoundCell)
    Loop
Else
    GoTo Nothing_Found
End If

Done:
Call Color_Cells(foundCellAddresses, Highlight_Color) '***
With Range(Cell_In_ActiveSheet_To_Store_FoundCellAddresses)  '***
    .Value = foundCellAddresses '***
    .Font.Color = .Interior.Color 'Make the text in this cell "invisible".  ***
End With '***

Dim complement_Address As String
complement_Address = ComplementOfBrokenUpRangeAddress(firstDataRow, lastDataRow, rangeWithOccurrences.address)

'If there is at least one row in the complement (which we are to hide),
If complement_Address <> "0" Then
    Sheets(sheetName).Range(complement_Address).EntireRow.Hidden = True
Else
    MsgBox Every_Row_Contained_The_Search, , "Search Bar"
End If

Exit Function
Nothing_Found:
If Tell_Me_That_There_Was_No_Results = True Then
    If search <> "" Then MsgBox Search_Was_Not_Found & vbNewLine & vbNewLine & Chr(34) & search & Chr(34), , "Search Bar"
End If
Filter_Rows = False

End Function

3 new functions necessary to color cells efficiently:

Sub Color_Cells(stringArrayOfCellsAddressesToColor As String, desiredColor As Variant)

'We uncolor previous cells with search results.
'But instead of doing it one by one (which is inefficient), we can do it in chunks of 28 to increase speed.
Dim cellAddressesToUnColor() As String
cellAddressesToUnColor = Split_Areas_Into_Sections_of_Size(28, stringArrayOfCellsAddressesToColor)

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
End With
Dim i As Integer
For i = 1 To UBound(cellAddressesToUnColor)
    Range(cellAddressesToUnColor(i)).Interior.Color = desiredColor
Next i
With Application
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
End With

End Sub

Sub Test__Split_Areas_Into_Sections_of_Size()
Dim areas As String
areas = "R3:R10,R12:R15,R17:R20,R22:R23,R25:R32,R34:R38,R41:R61,R63:R64,R66:R67,R70:R72,R74:R76,R79:R79,R82:R82,R84:R88,R90:R90,R93:R96,R102:R104,R106:R109,R111:R118,R123:R136,R138:R146,R148:R148,R150:R150,R152:R155,R157:R160,R163:R163,R165:R166,R168:R170,R172:R172,R174:R182,R184:R184,R186:R260,R1:R2,R1:R2,R1:R2,R8:R27,R8:R27,R8:R27,R62:R64,R62:R64,R62:R64,R66:R70,R66:R70,R66:R70,R76:R76,R76,R76:R76,R79:R79,R79,R79:R79,R83:R83,R83,R83:R83,R85:R85,R85,R85:R85,R98,R25:R32,R34:R38,R41:R61,R63:R64,X3,X3"
Call Print_Array(Split_Areas_Into_Sections_of_Size(28, areas))
End Sub
Function Split_Areas_Into_Sections_of_Size(sectionSize As Integer, areas As String)

Dim i As Integer, j As Integer, currentArea As Integer, currentSection As String
Dim s() As String: ReDim output(0 To 0) As String
s = Split(areas, ",")

currentArea = 0
If UBound(s) < sectionSize Then GoTo Remainder

'Sections of length sectionSize
For i = 1 To Int((UBound(s) - LBound(s) + 1) / sectionSize)
    currentSection = ""
    For j = 1 To sectionSize - 1
        currentSection = currentSection & s(currentArea) & ","
        currentArea = currentArea + 1
    Next j
    output = Append(output, currentSection & s(currentArea))
    currentArea = currentArea + 1
Next i

Remainder:
currentSection = ""
For i = currentArea To UBound(s) - 1
    currentSection = currentSection & s(i) & ","
Next i
Split_Areas_Into_Sections_of_Size = Append(output, currentSection & s(i))

End Function
Sub Test__Append()
ReDim sampleArray(1 To 2) As String
sampleArray(1) = "argument 1"
sampleArray(2) = "argument 2"
sampleArray = Append(sampleArray, "argument 3")
Call Print_Array(sampleArray)
End Sub
Function Append(arr As Variant, arg As Variant)
'Adds new argument to the end of the array.
'LBound(arr) To UBound(arr) - 1 instead of UBound(arr) - 1 for arrays whose LBound > 0.
ReDim Preserve arr(LBound(arr) To UBound(arr) + 1)
arr(UBound(arr)) = arg
Append = arr
End Function

Two new (small) functions where you specify the highlight color and the default color

Function Highlight_Color()
'What color to highlight cells that contain the search
Highlight_Color = RGB(255, 255, 0)
End Function
Function Default_Cell_Color()
'What color the cells are by default (for when unhighlighting cells)
Default_Cell_Color = xlNone
End Function

And one function to specify which cell the (temporary) list cell addresses to uncolor is to be stored. (It should be the same cell in all 30 sheets in your Workbook. It can be Cell [A1] if you offset your data tables, or it can be any cell that's "free" for VBA to edit and use.)

Function Cell_In_ActiveSheet_To_Store_FoundCellAddresses()
Cell_In_ActiveSheet_To_Store_FoundCellAddresses = "A1"
End Function

 

[irfan dedrani]

I want something like find function where I put value or text which I wanted to find in input box and it will directly jump me to that data in my active sheet

 

[irfan dedrani]

'add a command button on your Master Sheet referencing this Macro
res = InputBox("Who are you looking for?")
For w = 2 To Worksheets.Count
With Worksheets(w)
Set Rng = .Cells '<< The Entire Sheet is Searched
With Rng
Set MyChoice = .Find(What:=res)
If Not MyChoice Is Nothing Then
Application.Goto MyChoice
MsgBox "Found " & res & " on " & Worksheets(w).Name
Else
MsgBox "Could Not Find " & res & " on " & Worksheets(w).Name
End If
End With
End With
Next w
Worksheets(1).Activate
End Sub
i got this code from mr jim may thread
this works fine for 5 or 6 sheets but not for 30 sheets can i search individually on active sheets only

 

[cmowla]

this works fine for 5 or 6 sheets but not for 30 sheets can i search individually on active sheets only

I already wrote code that did explicitly what you asked for in the first post. Did you try the code?

I want something like find function where I put value or text which I wanted to find in input box and it will directly jump me to that data in my active sheet

But what if there is more than 1 search result of what you search for? (That's why I programmed it to filter out all rows which don't contain the search result, so that you know that all rows you see have the search result in them somewhere. My latest addition highlights the specific cells which contain the search phrase.

How do you propose it be designed for multiple occurrences if not like this?

 

[irfan dedrani]

I already wrote code that did explicitly what you asked for in the first post. Did you try the code?


But what if there is more than 1 search result of what you search for? (That's why I programmed it to filter out all rows which don't contain the search result, so that you know that all rows you see have the search result in them somewhere. My latest addition highlights the specific cells which contain the search phrase.

How do you propose it be designed for multiple occurrences if not like this?

i want it to be simple just like jim may has given coz i dont know much abt coding
and ur coding i am not able to understand u can try that code which i have given then u will understand