'-------------------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