I want to find, and highlight cells that have a particular value.
In this example I'm searching for the number 2.
The code finds and highlights the cells with the number 2, but it also highlights cells with the number 22, and 23 because they contain the number 2.
'Find Search Values on Sheet and Highlight
Sub Find_And_Highlight()
Dim Searchfor As String
Dim FirstFound As String
Dim Lastcell As Range
Dim FoundCell As Range
Dim rng As Range
Dim myRange As Range
Set myRange = ActiveSheet.UsedRange
Set Lastcell = myRange.Cells(myRange.Cells.Count)
Searchfor = "2"
Set FoundCell = myRange.Find(what:=Searchfor, after:=Lastcell)
'Test to see if anything was found
If Not FoundCell Is Nothing Then
FirstFound = FoundCell.Address
Else
GoTo NothingFound
End If
Set rng = FoundCell
'Loop until cycled through all finds
Do Until FoundCell Is Nothing
'Find next cell with Searchfor value
Set FoundCell = myRange.FindNext(after:=FoundCell)
'Add found cell to rng range variable
Set rng = Union(rng, FoundCell)
'Test to see if cycled through to first found cell
If FoundCell.Address = FirstFound Then Exit Do
Loop
'Highlight cells that contain searchfor value
rng.Interior.ColorIndex = 34
Exit Sub
'Error Handler
NothingFound:
MsgBox "No values were found in this worksheet"
End Sub
Please look at the comment provided by #Craig which you need to implement. i.e. you need to modify the Foundcell line like below:
Set FoundCell = myRange.Find(what:=Searchfor, after:=Lastcell, lookat:=xlWhole)
Caution: This option modifies the user's search settings in Excel so in future make sure to uncheck below option in the Find box.
However, since you are changing the background color of the cells, you really do not need VBA for this purpose. You can use Conditional Formatting | Highlight Cells Rules | Equal To as shown below:
And then fill in the value as appropriate:
Outcome will appear like this:
Highlight Found Cells
Uncomment the Debug.Print lines in the FindAndHighlight procedure to better understand its behavior.
Option Explicit
Sub FindAndHighlight()
' You could use these constants ('ByVal') as arguments of this procedure,
' when you could call it with 'FindAndHighlight "2", 34' from yet another
' procedure.
Const SearchString As String = "2"
Const cIndex As Long = 34
If ActiveSheet Is Nothing Then Exit Sub ' if run from add-in
If TypeName(ActiveSheet) <> "Worksheet" Then Exit Sub ' if e.g. chart
'Debug.Print "Worksheet Name: " & ActiveSheet.Name
Dim srg As Range: Set srg = ActiveSheet.UsedRange
'Debug.Print "Source Range Address: " & srg.Address(0, 0)
Dim frg As Range: Set frg = refFindStringInRange(srg, SearchString)
If frg Is Nothing Then
MsgBox "No occurrence of '" & SearchString & "' found in range '" _
& srg.Address(0, 0) & "' of worksheet '" & srg.Worksheet.Name _
& "'.", vbCritical, "Nothing Found"
Exit Sub
End If
'Debug.Print "Found Range Address: " & frg.Address(0, 0)
HighLightRangeUsingColorIndex frg, cIndex
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined of all cells
' whose contents are equal to a string.
' Remarks: The search is case-insensitive ('MatchCase') and is performed
' by rows ('SearchOrder') ascending ('SearchDirection',
' ('FindNext')), starting with the first cell ('After')
' of each area of the range.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function refFindStringInRange( _
ByVal SearchRange As Range, _
ByVal SearchString As String) _
As Range
If SearchRange Is Nothing Then Exit Function
Dim frg As Range
Dim arg As Range
Dim lCell As Range
Dim fCell As Range
Dim FirstAddress As String
For Each arg In SearchRange.Areas
Set lCell = arg.Cells(arg.Rows.Count, arg.Columns.Count)
Set fCell = Nothing
' By modifying the parameters of the arguments of the 'Find' method
' you can change the behavior of the function in many ways.
Set fCell = arg.Find(SearchString, lCell, xlFormulas, xlWhole, xlByRows)
If Not fCell Is Nothing Then
FirstAddress = fCell.Address
Do
If frg Is Nothing Then
Set frg = fCell
Else
Set frg = Union(frg, fCell)
End If
Set fCell = arg.FindNext(After:=fCell)
Loop Until fCell.Address = FirstAddress
End If
Next arg
If Not frg Is Nothing Then
Set refFindStringInRange = frg
End If
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Highlights the cells of a range using a color index.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub HighLightRangeUsingColorIndex( _
ByVal rg As Range, _
ByVal cIndex As Long)
If rg Is Nothing Then Exit Sub
If cIndex < 1 Or cIndex > 56 Then Exit Sub
rg.Interior.ColorIndex = cIndex
End Sub
Related
I would like excel to input the entire column with the title "Section" into the range variable 'sectioncol'.
Set sectioncol = range(range("A1:R1").Find(what:="Section", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False).Address & ":" & range("A1:R1").Find(what:="Section", LookIn:=xlValues, lookat:=xlWhole, MatchCase:=False).End(xlDown).Address)
I was expecting the range variable to return the cells containing data under the section column.
That line is too long (hard to read), and will fail if "Section" is not found.
Better to break it up into intermediate steps:
Dim rng As Range
Set rng = Range("A1:R1").Find( _
What:="Section", LookIn:=xlValues, _
LookAt:=xlWhole, MatchCase:=False)
If Not rng Is Nothing Then ' Test if Section was found
Dim sectioncol As Range
Set sectioncol = Range(rng, Cells(Rows.Count, rng.Column).End(xlUp))
End If
Reference a Data Column Range
(Long) Educational (Using Find)
Sub ReferenceDataColumnRange()
' Define constants.
Const HEADER_TITLE As String = "Section"
' Reference the worksheet.
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
' Reference the table range.
Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
Debug.Print "Entire Range: " & rg.Address(0, 0)
' Reference the header row range.
Dim hrg As Range: Set hrg = rg.Rows(1)
Debug.Print "Header Row Range: " & hrg.Address(0, 0)
' Attempt to reference the header cell.
Dim hCell As Range: Set hCell = hrg.Find(HEADER_TITLE, _
hrg.Cells(hrg.Cells.Count), xlFormulas, xlWhole)
' Check if the header cell was found (referenced).
If hCell Is Nothing Then
MsgBox "The header """ & HEADER_TITLE & """ was not found.", vbCritical
Exit Sub
End If
Debug.Print "Header Cell: " & hCell.Address(0, 0) _
' Check if there is any data below the headers.
If rg.Rows.Count = 1 Then
MsgBox "No data below the header """ & HEADER_TITLE & """.", vbCritical
Exit Sub
End If
' Reference the data column range (no headers).
Dim crg As Range: Set crg = rg.Columns(hCell.Column - rg.Column + 1) _
.Resize(rg.Rows.Count - 1).Offset(1)
Debug.Print "Data Column Range: " & crg.Address(0, 0)
End Sub
(Short) Practical (Using Application.Match)
Sub ReferenceDataColumnRangeShort()
Dim crg As Range
With ActiveSheet.Range("A1").CurrentRegion
Dim cIndex: cIndex = Application.Match("Section", .Rows(1), 0)
If IsNumeric(cIndex) Then ' header found
If .Rows.Count > 1 Then ' data found
Set crg = .Columns(cIndex).Resize(.Rows.Count - 1).Offset(1)
End If
End If
End With
If crg Is Nothing Then Exit Sub
MsgBox crg.Address(0, 0), vbInformation
End Sub
Note that you can also write the first code in a short version.
It's up to you to determine which details are important (known) in each particular case.
This question already has an answer here:
Can the Excel VBA Range.Find method be used to find multiple values?
(1 answer)
Closed 1 year ago.
I have a find function that search through a column, and there might be more than one result. Which I would like to store in a range (instead of a separate array for example).
This is what I have:
Dim searchRange As Range
Set searchRange = ActiveWorkbook.Sheets(SHEET).Range(SEARCHFOLDERCOLUMN & SEARCHSTARTROW & ":" & SEARCHFOLDERCOLUMN & lastRow)
'search for value
Dim searchResult As Range
Dim firstAddress As String
Set searchResult = searchRange.Find(what:=sSearchFolder, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not searchResult Is Nothing The
firstAddress = searchResult.Address
Do
'search for the next one
Debug.Print searchResult.Address
Set searchResult = searchRange.FindNext(searchResult)
'^^^^^ union instead of this ???
'avoid endless loop, when hitting back the first address
If firstAddress = searchResult.Address Then
'Set searchResult = tempSearchResult
Exit Do
End If
Loop While Not searchResult Is Nothing
End If
Debug.Print "out of loop"
My output:
$M$125
$M$148
$M$161
out of loop
How can I get a range like: "$M$125, $M$148, $M$161" ? Where the columns (or rows?) or 3 instead of 1 like I have now.
Thanks for your help.
Reference a 'FindNext Multi Range'
Option Explicit
Sub DebugPrintCCRGtest()
' Needs 'DebugPrintCCRG', 'RefColumn' and 'RefCriteriaColumnRange'.
DebugPrintCCRG ""
DebugPrintCCRG "Yes"
DebugPrintCCRG "No"
DebugPrintCCRG "2"
' Example Results:
' A4,A8:A9,A17
' A2:A3,A7,A12:A14,A21
' A6,A15:A16,A18:A19
' A5,A10:A11,A20
End Sub
Sub DebugPrintCCRG( _
ByVal Criteria As String)
' Needs 'RefColumn' and 'RefCriteriaColumnRange'.
Dim sFirst As String: sFirst = "A2"
Dim ws As Worksheet: Set ws = ActiveSheet ' be more specific
Dim crg As Range: Set crg = RefColumn(ws.Range(sFirst))
If crg Is Nothing Then Exit Sub
Dim ccrg As Range: Set ccrg = RefCriteriaColumnRange(crg, Criteria)
If ccrg Is Nothing Then Exit Sub
Debug.Print ccrg.Address(0, 0)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the range combined from all the cells
' of a one-column range ('crg'), whose values are equal
' to a string ('Criteria').
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCriteriaColumnRange( _
ByVal crg As Range, _
ByVal Criteria As String) _
As Range
If crg Is Nothing Then Exit Function
Dim cCell As Range: Set cCell = crg.Find(Criteria, _
crg.Cells(crg.Cells.Count), xlFormulas, xlWhole)
If cCell Is Nothing Then Exit Function
Dim drg As Range: Set drg = cCell
Dim FirstAddress As String: FirstAddress = cCell.Address
Do
Set drg = Union(drg, cCell)
Set cCell = crg.FindNext(cCell)
Loop Until cCell.Address = FirstAddress
If drg Is Nothing Then Exit Function
Set RefCriteriaColumnRange = drg
End Function
How can highlight in yellow a cell that have a specific word in it?
I have data in colum B and F with the word "No Game".
How can I have this in a vba in excel?
Thanks
Although this question has already been answered, I'd take my chance, showing how easy this is using conditional formatting (screenshots are minimised a bit):
Result looks like this:
Good luck
Highlight Matches (For Each...Next)
Copy the complete code into a standard module, e.g. Module1.
Adjust (play with) the values in the constants section.
Option Explicit
Sub HighlightColumns()
' Needs the 'RefColumn' and 'RefCombinedRange' functions.
Const ProcTitle As String = "Highlight Columns"
Const wsName As String = "Sheet1"
Const FirstCellsList As String = "B2,H2"
Const hCriteria As String = "No Game"
Const hColor As Long = vbYellow
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
' Write the list of the first cells' addresses to an array ('FirstCells').
Dim FirstCells() As String: FirstCells = Split(FirstCellsList, ",")
Dim scrg As Range ' Source Column Range
Dim sfCell As Range ' Source First Cell
Dim sCell As Range ' Source Cell
Dim hrg As Range ' Highlight Range
Dim n As Long ' Columns Counter
' Combine all matching cells into the Highlight Range.
For n = 0 To UBound(FirstCells)
Set sfCell = ws.Range(FirstCells(n))
Set scrg = RefColumn(sfCell)
If Not scrg Is Nothing Then ' found data in column range
For Each sCell In scrg.Cells
If StrComp(CStr(sCell.Value), hCriteria, vbTextCompare) = 0 Then
Set hrg = RefCombinedRange(hrg, sCell)
'Else ' not a match
End If
Next sCell
Set scrg = Nothing
'Else ' no data in current column range
End If
Next n
' Highlight and inform.
If Not hrg Is Nothing Then ' Highlight Criteria found
hrg.Interior.Color = hColor
MsgBox "Highlighted cells equal to '" & hCriteria & "'.", _
vbInformation, ProcTitle
Else ' no Highlight Criteria found
MsgBox "No occurrences of '" & hCriteria & "' found.", _
vbExclamation, ProcTitle
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to a range combined from two ranges.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefCombinedRange( _
ByVal CombinedRange As Range, _
ByVal AddRange As Range) _
As Range
If CombinedRange Is Nothing Then
Set RefCombinedRange = AddRange
Else
Set RefCombinedRange = Union(CombinedRange, AddRange)
End If
End Function
I'd like to know how to write this range changing "G" to a string variable strColumn.
This is the code I want to change:
Dim lastRowElemento As Integer
lastRowElemento = Cells(Rows.Count, "G").End(xlUp).Row
Set rngElemento = ws.Range("G2:G" & lastRowElemento)
Applying OP's method, try this:
Sub TEST()
Dim ws As Worksheet, Rng As Range, sCol As String
sCol = "G"
Set ws = ThisWorkbook.Sheets("TEST") 'change as required
With ws.Columns(sCol)
Set Rng = Range(.Cells(2), .Cells(.Rows.Count).End(xlUp))
End With
End Sub
Reference a 'Non-Empty' Column Range
There are actually two requirements:
ColumnString = G (I prefer string since e.g. XFD are letters)
FirstRow = 2
If you put them together, you get G2 (think one, instead of two variables).
Since using the Find method is more reliable than using the End property in finding the bottom-most (last) non-empty cell in a column, I used it to write the RefColumn function which in your case can be utilized in the following way:
Set rngElemento = RefColumn(ws.Range("G2"))
I'll leave it up to you if you're going to test if there is data (usually you know there is), but I prefer to keep at least a 'simplified' test in the code:
If rngElemento is Nothing Then Exit Sub ' no data
' Continue...
The Code
Option Explicit
Sub RefColumnTEST()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim ws As Worksheet: Set ws = wb.Worksheets("Sheet1")
Dim rg As Range: Set rg = RefColumn(ws.Range("G2"))
If rg Is Nothing Then ' the range 'G2:G1048576' is empty
MsgBox "No data.", vbCritical
Else
MsgBox rg.Address(0, 0), vbInformation
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Creates a reference to the one-column range from the first cell
' of a range ('FirstCell') to the bottom-most non-empty cell
' of the first cell's worksheet column.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function RefColumn( _
ByVal FirstCell As Range) _
As Range
If FirstCell Is Nothing Then Exit Function
With FirstCell.Cells(1)
Dim lCell As Range
Set lCell = .Resize(.Worksheet.Rows.Count - .Row + 1) _
.Find("*", , xlFormulas, , , xlPrevious)
If lCell Is Nothing Then Exit Function
Set RefColumn = .Resize(lCell.Row - .Row + 1)
End With
End Function
Meeting Your Requirements
Similarly to my preferred way, you could use the RefData function:
Function RefData( _
ByVal ws As Worksheet, _
ByVal ColumnIndex As Variant) _
As Range
On Error GoTo ClearError
With ws.Columns(ColumnIndex).Resize(ws.Rows.Count - 1).Offset(1)
Set RefData = _
.Resize(.Find("*", , xlFormulas, , , xlPrevious).Row - 1)
End With
ProcExit:
Exit Function
ClearError:
Resume ProcExit
End Function
which you can utilize in the following way:
Set rngElemento = RefData(ws, "G")
Set rngElemento = RefData(ws, 7)
' or:
Const strColumn As String = "G"
Set rngElemento = RefData(ws, strColumn)
I am new to VBA... I am trying delete all columns from Sheet1:"Template" ROW1/headers file that doesn't match any of the cell values on varList:"ColumnsList" (that is in Sheet3).
How do I select the headers or how do I select the row 1 range to search into?
Also, I have a runtime error 5 in this line: invalid procedure call or argument.
If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then
Any kind soul that help me with that please?
Also, I need to do the same but with rows from Sheet1:"Template". I need to delete any row that doesn't CONTAIN any cell value from varList:"Agents" (that is in Sheet2).
Could you please help me out?
Maaaany thanks in advance!!!
Option Compare Text
Sub ModifyTICBData()
Dim varList As Variant
Dim lngarrCounter As Long
Dim rngFound As Range, rngToDelete As Range
Dim strFirstAddress As String
'Application.ScreenUpdating = False
varList = VBA.Array("ColumnsList") 'I want to keep columns with these values, NOT DELETE THEM
For lngarrCounter = LBound(varList) To UBound(varList)
With Sheets("Template").UsedRange
Set rngFound = .Find( _
What:=varList(lngarrCounter), _
Lookat:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=True)
If Not rngFound Is Nothing Then
strFirstAddress = rngFound.Address
If rngToDelete Is Nothing Then
Set rngToDelete = rngFound
Else
If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
End If
Set rngFound = .FindNext(After:=rngFound)
Do Until rngFound.Address = strFirstAddress
If Application.Intersect(rngToDelete, rngFound.EntireColumn) Is Nothing Then
Set rngToDelete = Application.Union(rngToDelete, rngFound)
End If
Set rngFound = .FindNext(After:=rngFound)
Loop
End If
End With
Next lngarrCounter
Dim rngDel As Range
Set rngDel = NotIntersectRng(Sheets("Template").UsedRange, rngToDelete)
If Not rngDel Is Nothing Then rngDel.EntireColumn.delete
'Application.ScreenUpdating = True
End Sub
Private Function NotIntersectRng(rng As Range, rngF As Range) As Range
Dim rngNI As Range, i As Long, j As Long
For i = 1 To rng.Columns.Count
**If Intersect(rng.Cells(1, i).EntireColumn, rngF) Is Nothing Then**
If rngNI Is Nothing Then
Set rngNI = rng.Cells(1, i)
Else
Set rngNI = Union(rngNI, rng.Cells(1, i))
End If
End If
Next i
If Not rngNI Is Nothing Then Set NotIntersectRng = rngNI
End Function
Delete Columns, Then Rows
Description
Deletes columns that in the first row do not contain values from a list. Then deletes rows that in the first column do not contain values from another list.
The Flow
Writes the values from range A2 to the last cell in Sheet3 to the Cols Array.
Writes the values from range A2 to the last cell in Sheet2 to the Agents Array.
Using CurrentRegion defines the DataSet Range (rng).
Loops through the cells (cel) in first row starting from the 2nd column and compares their values to the values from the Cols Array. If not found adds the cells to the Delete Range(rngDel).
Finally deletes the entire columns of the cells 'collected'.
Loops through the cells (cel) in first column starting from the 2nd row and compares their values to the values from the Agents Array. If not found adds the cells to the Delete Range(rngDel).
Finally deletes the entire rows of the cells 'collected'.
Informs the user of success or no action.
The Code
Option Explicit
Sub ModifyTICBData()
' Define workbook ('wb').
Dim wb As Workbook
Set wb = ThisWorkbook
' Define Columns List ('Cols').
Dim ws As Worksheet
Set ws = wb.Worksheets("Sheet3")
Dim rng As Range
Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
Dim Cols As Variant
Cols = ws.Range("A2", rng).Value
' Define Agents List ('Agents').
Set ws = wb.Worksheets("Sheet2")
Set rng = ws.Cells(ws.Rows.Count, "A").End(xlUp)
Dim Agents As Variant
Agents = ws.Range("A2", rng).Value
' Define DataSet Range ('rng').
Set rng = wb.Worksheets("Template").Range("A1").CurrentRegion
Application.ScreenUpdating = False
' Define Delete Range ('rngDel') for Columns.
Dim rngDel As Range
Dim cel As Range
For Each cel In rng.Rows(1).Resize(, rng.Columns.Count - 1) _
.Offset(, 1).Cells
If IsError(Application.Match(cel.Value, Cols, 0)) Then
collectCells rngDel, cel
End If
Next cel
' Delete Columns.
Dim AlreadyDeleted As Boolean
If Not rngDel Is Nothing Then
rngDel.EntireColumn.Delete
Else
AlreadyDeleted = True
End If
' Define Delete Range ('rngDel') for Agents.
Set rngDel = Nothing
For Each cel In rng.Columns("A").Resize(rng.Rows.Count - 1) _
.Offset(1).Cells
If IsError(Application.Match(cel.Value, Agents, 0)) Then
collectCells rngDel, cel
End If
Next cel
' Delete Agents (Rows).
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
AlreadyDeleted = False
End If
Application.ScreenUpdating = True
' Inform user
If Not AlreadyDeleted Then
MsgBox "The data was succesfully deleted.", vbInformation, "Success"
Else
MsgBox "The data had already been deleted.", vbExclamation, "No Action"
End If
End Sub
Sub collectCells(ByRef CollectRange As Range, CollectCell As Range)
If Not CollectCell Is Nothing Then
If Not CollectRange Is Nothing Then
Set CollectRange = Union(CollectRange, CollectCell)
Else
Set CollectRange = CollectCell
End If
End If
End Sub