Excel unique value query - excel

I'm not very experienced with excel -- I'm much more of a c# guy -- was hoping some of the excel gurus could help me out here!
Basically I have a spreadsheet that has only one column of text data (column a). I need to query this list of data.
I will be needing to basically copy in some more text data into another column (let's say column b), and then filter out the records in column b that are already present somewhere in column a, leaving me with only the unique records that are in column b, but not column a.
I've tried using the advanced filter but can't seem to get it to work. Any tips or advice on how I can do this would be great.
Thanks

You can filter your data dynamically, say into column C with formulas like
=IF(ISNA(VLOOKUP(B1,A:A,1,FALSE)),B1,"")
And then filter non-empty cells in column C
Otherwise this simple macro will clear the duplicates in place
Sub FilterDuplicates()
Dim r As Range
For Each r In ActiveSheet.Columns("B").Cells
If r.Value <> "" Then
On Error Resume Next
WorksheetFunction.VLookup r, ActiveSheet.Columns("A"), 1, False
If Err.Number = 0 Then r.ClearContents
On Error GoTo 0
End If
Next r
End Sub

This should do what you need. It looks for each value in column B in column A and deletes the cell if it finds a match. Run the code after you've pasted your data into column B. Note that it doesn't remove duplicates from column B, it just removes any values from column B that are in column A. To remove dupes from column B, select the column and choose Remove Duplicates from the Data tab.
You'll need to add a module to the workbook and insert the following code in the module:
code:
Option Explicit
Sub RemoveMatchesFromColumn()
On Error Resume Next
Dim LastRow As Long
Dim SearchText As String
Dim MatchFound As String
LastRow = Range("b" & ActiveSheet.Rows.Count).End(xlUp).Row
SearchText = Range("b" & LastRow).Value
Do Until LastRow = 0
MatchFound = Find_Range(SearchText, Columns("A")).Value
If SearchText = MatchFound Then
Range("b" & LastRow).Delete Shift:=xlUp
End If
LastRow = LastRow - 1
SearchText = Range("b" & LastRow).Value
Loop
End Sub
Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range
' Function written by Aaron Blood
' http://www.ozgrid.com/forum/showthread.php?t=27240
Dim c As Range
Dim firstAddress As Variant
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlPart 'xlWhole
If IsMissing(MatchCase) Then MatchCase = False
With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> firstAddress
End If
End With
End Function
Run the sub RemoveMatchesFromColumn. You can step into it to see what it's doing F8 or run it with F5.

NON VBA METHOD
Put this formula in Cell C1
=IF(VLOOKUP(B1,A:A,1,0)=B1,"DELETE ME","")
Drag it till the end. and then filter the data on Col C for DELETE ME And then delete the duplicate data.
VBA METHOD
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim delRange As Range, aCell As Range
Set ws = Sheets("Sheet1")
With ws
lRow = .Range("B" & Rows.Count).End(xlUp).Row
For i = 1 To lRow
Set aCell = .Columns(1).Find(What:=.Range("B" & i).Value, _
LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
If delRange Is Nothing Then
Set delRange = .Range("B" & i)
Else
Set delRange = Union(delRange, .Range("B" & i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.Delete shift:=xlUp
End With
End Sub

Related

Select range with VBA - got stuck

I got little project in VBA and stuck on below topic.
I need to select range from searched value to first empty cell in H column.
Selected range should looks like this
Selected Range in Excel:
I searched for specific value in column A and if I found it it's being set as first cell in range. ( It works)
Then I need to find last cell in range which is first empty cell in last column.
This is what I've found and try to use
Sub Button()
Dim StringToFind As String
StringToFind = Application.InputBox("Enter string to find", "Find string")
Worksheets("SS19").Activate
ActiveSheet.Range("A:A").Select
Set cell = Selection.Find(What:=StringToFind, After:=ActiveCell, _
LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
cell.Select
With Worksheets("SS19")
Set rr = .Range(ActiveCell, .Cells(.Rows.Count, "H").End(xlUp))
With rr
rr.Parent.Range(.Cells(1, "A"), .Cells(.Rows.Count, "H").End(xlUp).Offset(1, 0)).Select
End With
End With
If cell Is Nothing Then
Worksheets("SS19").Activate
MsgBox "String not found"
End If
I tried to searched for first empty cell in prevously selected range so it won't search the whole column but it doesn't work.
Try this...
Dim StringToFind As String
StringToFind = Application.InputBox("Enter string to find", "Find string")
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet2")
With ws
Dim findCel As Range
Set findCel = .Range("A:A").Find(StringToFind, , , xlWhole, , , False, , False)
Dim lRow As Long
lRow = .Range(findCel.Address).Offset(, 7).End(xlDown).Row + 1
Dim rr As Range
Set rr = .Range("A" & findCel.Row & ":" & "H" & lRow)
rr.Select
End With
I find that using the worksheet's match function is easier than Range.Find when searching a single column.
Option Explicit
Sub Button()
Dim stringToFind As String, m As Variant
Worksheets("SS19").Activate
stringToFind = Application.InputBox("Enter string to find", "Find string", Type:=xlTextValues)
With Worksheets("SS19")
m = Application.Match(stringToFind, .Range("A:A"), 0)
If Not IsError(m) Then
If Not IsEmpty(.Cells(m + 1, "H")) Then
.Range(.Cells(m, "A"), .Cells(m, "H").End(xlDown).Offset(1)).Select
Else
.Range(.Cells(m, "A"), .Cells(m, "H").Offset(1)).Select
End If
End If
End With
End Sub
Using .End(xlDown) could be problematic if the first cell under row m in column H was blank and this should be checked for or you might find the selection reaching too far, possibly all the way down to the bottom of the worksheet. Checking for a non-blank cell will catch this potential problem.

Find a value from a range of cells in column over many sheets and return a "X" in next empty column

I'm trying to put a "X" or what ever in a the next empty column that I later can use INDEX and INDERECT (since the sheets are named the same as the range in column A in my main sheet) to look up for my main sheet. The "X" needs to be added in each of the sheets where the value is found.
The column in the sheets where the numbers I need to find the value is always in column A. In my main sheet the values are listed from B2:B23. The range varies in each sheet (from 400 to 5000 rows).
Is there a clever way of doing this that I haven't found still?
atm there are 80 sheets and the one main sheet
Code:
Sub Mark_cells_in_column()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim I As Long
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Search for a Value Or Values in a range
MyArr = Array("34-2472", "36-437", "36-4351", "36-4879", "36-4982", "36-4981" _
, "36-5715", "36-4983", "36-4984", "36-5125", "36-5126", "36-5257", "36-6139" _
, "38-7079-1", "38-7079-2", "44-1276", "31-8589", "31-8589-1", "31-8647", "36-6149" _
, "36-5770", "31-8590")
'Search Column or range
With Sheets("3").Range("A:A") 'cant get my head around how to get this to apply so it loops through every sheet except main sheet
'clear the cells in the column to the right
.Offset(0, 13).ClearContents
For I = LBound(MyArr) To UBound(MyArr)
'If you want to find a part of the rng.value then use xlPart
'if you use LookIn:=xlValues it will also work with a
'formula cell that evaluates to "values listed"
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
'mark the cell in the column to the right if "Values listed" is found
Rng.Offset(0, 13).Value = "X"
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Here you go:
Sub Mark_cells_in_column()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim I As Long
Dim mainWS As Worksheet, ws As Worksheet
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set mainWS = Sheets("Main") ' Change this to whatever the name of your Main WS is, that you DON'T want to run the macro on
'Search for a Value Or Values in a range
MyArr = Array("34-2472", "36-437", "36-4351", "36-4879", "36-4982", "36-4981" _
, "36-5715", "36-4983", "36-4984", "36-5125", "36-5126", "36-5257", "36-6139" _
, "38-7079-1", "38-7079-2", "44-1276", "31-8589", "31-8589-1", "31-8647", "36-6149" _
, "36-5770", "31-8590")
' Loop through Sheets
For Each ws In Worksheets
If ws.Name <> mainWS.Name Then
With ws
'Search Column or range
With .Range("A:A")
'clear the cells in the column to the right 13 columns (aka column N)
.Offset(0, 13).ClearContents
For I = LBound(MyArr) To UBound(MyArr)
'If you want to find a part of the rng.value then use xlPart
'if you use LookIn:=xlValues it will also work with a
'formula cell that evaluates to "values listed"
Set Rng = .Cells.Find(What:=MyArr(I), _
After:=.Cells(1, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
'mark the cell in the column to the right if "Values listed" is found
Rng.Offset(0, 13).Value = "X" ' This marks it in 13 columns to the right where the value is found
Set Rng = .Columns("A:A").FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With ' Ends the .Range("A:A")
End With ' ends the `with WS`
End If
Next ws
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
The main thing seemed to be you were using the very last cell (After:=.Cells(.Cells.Count)) with SearchDirection:=xlNext. ...there's no next cell, if you're at the end! So, I changed that to After:=.Cells(1,1).
Secondly, I added a loop to check the worksheets, and if it's "Main", skip it. Edit as required.

Set VBA Range with Variable End

I'm kind of new to VBA and am struggling to understand some of the syntax.
I have a range from a3:c13, for example, and I'd like to set it as a variable so I can pass it to vlookup later as a the table array. However, the range is defined by user input in terms of its size. It will always start in A3, it will always include columns A:C, but I don't know how far down it would go. In that case, I think I'd set it as:
With range("a3")
table_array = range(.cells(0,0), .End(xlDown).End(xlToRight)).Select
End With
However, that doesn't seem to work. I get a runtime error:
Run-time Error '1004': Method '_Default' of object 'Range' failed.
Assuming cols A, B, and C have the same number of rows:
Sub Macro1()
Set r = Range("A3")
Set table_array = Range(r, r.End(xlDown)).Resize(, 3)
End Sub
You can find the last row in Col A:C and then construct your range?
Sub Sample()
Dim ws As Worksheet
Dim LastRow As Long
Dim Rng As Range
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
LastRow = .Range("A:C").Find(What:="*", _
After:=.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
Else
LastRow = 1
End If
If Not LastRow < 3 Then
Set Rng = .Range("A3:C" & LastRow)
Debug.Print Rng.Address
Else
MsgBox "No Data found beyond A3"
End If
End With
End Sub

Not getting values of all rows after auto filtering with for loop

I am struggling for writing the code - below query please help any one on writing it.
TestDataSheetName = ActiveWorkbook.Worksheets(x).Name
ActiveWorkbook.Worksheets(x).Activate
CountTestData = ActiveWorkbook.Worksheets(x).Range("A" & Rows.Count).End(xlUp).Row
Range("A10").Select
Range("A10").AutoFilter
Selection.AutoFilter Field:=14, Criteria1:=">=" & DateToday
ActiveWorkbook.Worksheets(x).Activate
CountTestDataAftFilter = ActiveWorkbook.Worksheets(x).Range("A1", Range("A65536").End(xlUp)).SpecialCells(xlCellTypeVisible).Count
MsgBox CountTestDataAftFilter
For w = 10 To CountTestDataAftFilter
Set Foundcell1 = ActiveWorkbook.Worksheets(x).Cells.Find(What:=DateToday, After:=[ActiveCell], _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
Next
' after filtering with today's date i got 5 rows with today's date and i have written for loop for getting all row values but after finding first row then it is not finding the second row value and it is again start with first row
Please help me on above code.
Thanks&Regards,
Basha
You're looking for the .FindNext function. Try something like this: (Please note, you may need to modify this code slightly to fit your particular case.)
Sub UseFindNext()
Dim TestDataSheet As Worksheet
Dim FoundCell1 As Range
Dim DateToday As Date
Dim firstAddress As String
Dim x As Long
Dim CountTestData As Long
Dim CountTestDataAftFilter As Long
x = 1
Set TestDataSheet = ActiveWorkbook.Worksheets(x)
CountTestData = TestDataSheet.Range("A" & Rows.count).End(xlUp).Row
Range("A10").AutoFilter Field:=14, Criteria1:=">=" & DateToday
CountTestDataAftFilter = TestDataSheet.Range("A1", Rows.count).End(xlUp)).SpecialCells(xlCellTypeVisible).count
Set FoundCell1 = TestDataSheet.Cells.Find(What:=DateToday, After:=TestDataSheet.Range("A10"), _
SearchOrder:=xlByRows, SearchDirection:=xlNext, _
LookIn:=xlValues, LookAt:=xlPart, MatchCase:=True)
firstAddress = FoundCell1.Address
Do
'Do whatever you're looking to do with each cell here. For example:
Debug.Print FoundCell1.Value
Loop While Not FoundCell1 Is Nothing And FoundCell1.Address <> firstAddress
End Sub
I don't know why you have to go through each value.
You already used AutoFilter to get the data you want.
But here's another approach that might work for you.
Sub test()
Dim ws As Worksheet
Dim wb As Workbook
Dim DateToday As String 'i declared it as string for the filtering
Dim rng, cel As Range
Dim lrow As Long
Set wb = ThisWorkbook
Set ws = wb.Sheets(x)
DateToday = "Put here whatever data you want" 'put value on your variable
With ws
lrow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("N10:N" & lrow).AutoFilter Field:=1, Criteria1:=DateToday
'I used offset here based on the assumption that your data has headers.
Set rng = .Range("N10:N" & lrow).Offset(1, 0).SpecialCells(xlCellTypeVisible)
'here you can manipulate the each cell values of the currently filtered range
For Each cel In rng
cel.EntireRow 'use .EntireRow to get all the data in the row and do your stuff
Next cel
.AutoFilterMode = False
End With
End Sub
BTW, this is based on this post which you might want to check as well to improve coding.
It is a good read. Hope this helps.

Getting the actual usedrange

I have a Excel worksheet that has a button.
When I call the usedRange() function, the range it returns includes the button part.
Is there anyway I can just get actual used range that contains data?
What sort of button, neither a Forms Control nor an ActiveX control should affect the used range.
It is a known problem that excel does not keep track of the used range very well. Any reference to the used range via VBA will reset the value to the current used range. So try running this sub procedure:
Sub ResetUsedRng()
Application.ActiveSheet.UsedRange
End Sub
Failing that you may well have some formatting hanging round. Try clearing/deleting all the cells after your last row.
Regarding the above also see:
Excel Developer Tip
Another method to find the last used cell:
Dim rLastCell As Range
Set rLastCell = ActiveSheet.Cells.Find(What:="*", After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
Change the search direction to find the first used cell.
Readify made a very complete answer. Yet, I wanted to add the End statement, you can use:
Find the last used cell, before a blank in a Column:
Sub LastCellBeforeBlankInColumn()
Range("A1").End(xldown).Select
End Sub
Find the very last used cell in a Column:
Sub LastCellInColumn()
Range("A" & Rows.Count).End(xlup).Select
End Sub
Find the last cell, before a blank in a Row:
Sub LastCellBeforeBlankInRow()
Range("A1").End(xlToRight).Select
End Sub
Find the very last used cell in a Row:
Sub LastCellInRow()
Range("IV1").End(xlToLeft).Select
End Sub
See here for more information (and the explanation why xlCellTypeLastCell is not very reliable).
Here's a pair of functions to return the last row and col of a worksheet, based on Reafidy's solution above.
Function LastRow(ws As Object) As Long
Dim rLastCell As Object
On Error GoTo ErrHan
Set rLastCell = ws.Cells.Find("*", ws.Cells(1, 1), , , xlByRows, _
xlPrevious)
LastRow = rLastCell.Row
ErrExit:
Exit Function
ErrHan:
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbExclamation, "LastRow()"
Resume ErrExit
End Function
Function LastCol(ws As Object) As Long
Dim rLastCell As Object
On Error GoTo ErrHan
Set rLastCell = ws.Cells.Find("*", ws.Cells(1, 1), , , xlByColumns, _
xlPrevious)
LastCol = rLastCell.Column
ErrExit:
Exit Function
ErrHan:
MsgBox "Error " & Err.Number & ": " & Err.Description, _
vbExclamation, "LastRow()"
Resume ErrExit
End Function
Public Sub FindTrueUsedRange(RowLast As Long, ColLast As Long)
Application.EnableEvents = False
Application.ScreenUpdating = False
RowLast = 0
ColLast = 0
ActiveSheet.UsedRange.Select
Cells(1, 1).Activate
Selection.End(xlDown).Select
Selection.End(xlDown).Select
On Error GoTo -1: On Error GoTo Quit
Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Activate
On Error GoTo -1: On Error GoTo 0
RowLast = Selection.Row
Cells(1, 1).Activate
Selection.End(xlToRight).Select
Selection.End(xlToRight).Select
Cells.Find(What:="*", LookIn:=xlFormulas, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Activate
ColLast = Selection.Column
Quit:
Application.ScreenUpdating = True
Application.EnableEvents = True
On Error GoTo -1: On Error GoTo 0
End Sub
This function returns the actual used range to the lower right limit. It returns "Nothing" if the sheet is empty.
'2020-01-26
Function fUsedRange() As Range
Dim lngLastRow As Long
Dim lngLastCol As Long
Dim rngLastCell As Range
On Error Resume Next
Set rngLastCell = ActiveSheet.Cells.Find("*", searchorder:=xlByRows, searchdirection:=xlPrevious)
If rngLastCell Is Nothing Then 'look for data backwards in rows
Set fUsedRange = Nothing
Exit Function
Else
lngLastRow = rngLastCell.Row
End If
Set rngLastCell = ActiveSheet.Cells.Find("*", searchorder:=xlByColumns, searchdirection:=xlPrevious)
If rngLastCell Is Nothing Then 'look for data backwards in columns
Set fUsedRange = Nothing
Exit Function
Else
lngLastCol = rngLastCell.Column
End If
Set fUsedRange = ActiveSheet.Range(Cells(1, 1), Cells(lngLastRow, lngLastCol)) 'set up range
End Function
I use the following vba code to determine the entire used rows range for the worksheet to then shorten the selected range of a column:
Set rUsedRowRange = Selection.Worksheet.UsedRange.Columns( _
Selection.Column - Selection.Worksheet.UsedRange.Column + 1)
Also works the other way around:
Set rUsedColumnRange = Selection.Worksheet.UsedRange.Rows( _
Selection.Row - Selection.Worksheet.UsedRange.Row + 1)
This function gives all 4 limits of the used range:
Function FindUsedRangeLimits()
Set Sheet = ActiveSheet
Sheet.UsedRange.Select
' Display the range's rows and columns.
row_min = Sheet.UsedRange.Row
row_max = row_min + Sheet.UsedRange.Rows.Count - 1
col_min = Sheet.UsedRange.Column
col_max = col_min + Sheet.UsedRange.Columns.Count - 1
MsgBox "Rows " & row_min & " - " & row_max & vbCrLf & _
"Columns: " & col_min & " - " & col_max
LastCellBeforeBlankInColumn = True
End Function
Timings on Excel 2013 fairly slow machine with a big bad used range million rows:
26ms Cells.Find xlPrevious method (as above)
0.4ms Sheet.UsedRange (just call it)
0.14ms Counta binary search + 0.4ms Used Range to start search (12 CountA calls)
So the Find xlPrevious is quite slow if that is of concern.
The CountA binary search approach is to first do a Used Range. Then chop the range in half and see if there are any non-empty cells in the bottom half, and then halve again as needed. It is tricky to get right.
Here's another one. It looks for the first and last non empty cell and builds are range from those. This also handles cases where your data is not rectangular and does not start in A1. Furthermore it handles merged cells as well, which .Find skips when executed from a macro, used on .Cells on a worksheet.
Function getUsedRange(ByRef sheet As Worksheet) As Range
' finds used range by looking for non empty cells
' works around bug in .Find that skips merged cells
' by starting at with the UsedRange (that may be too big)
' credit to https://contexturesblog.com/archives/2012/03/01/select-actual-used-range-in-excel-sheet/
' for the .Find commands
Dim excelsUsedRange As Range
Dim lastRow As Long
Dim lastCol As Long
Dim lastCell As Range
Dim firstRow As Long
Dim firstCol As Long
Dim firstCell As Range
Set excelsUsedRange = ActiveSheet.UsedRange
lastRow = excelsUsedRange.Find(What:="*", _
LookIn:=xlValues, SearchOrder:=xlRows, _
SearchDirection:=xlPrevious).Row
lastCol = excelsUsedRange.Find(What:="*", _
LookIn:=xlValues, SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious).Column
Set lastCell = sheet.Cells(lastRow, lastCol)
firstRow = excelsUsedRange.Find(What:="*", After:=lastCell, _
LookIn:=xlValues, SearchOrder:=xlRows, _
SearchDirection:=xlNext).Row
firstCol = excelsUsedRange.Find(What:="*", After:=lastCell, _
LookIn:=xlValues, SearchOrder:=xlByColumns, _
SearchDirection:=xlNext).Row
Set firstCell = sheet.Cells(firstRow, firstCol)
Set getUsedRange = sheet.Range(firstCell, lastCell)
End Function
This is a different approach to the other answers, which will give you all the regions with data - a Region is something enclosed by an empty row and column and or the the edge of the worksheet. Basically it gives all the rectangles of data:
Public Function ContentRange(ByVal ws As Worksheet) As Range
'First, identify any cells with data, whose neighbourhood we will inspect
' to identify contiguous regions of content
'For efficiency, restrict our search to only the UsedRange
' NB. This may be pointless if .SpecialCells does this internally already, it probably does...
With ws.UsedRange 'includes data and cells that have been formatted
Dim cellsWithContent As Range
On Error Resume Next '.specialCells will error if nothing found, we can ignore it though
Set cellsWithContent = .SpecialCells(xlCellTypeConstants)
Set cellsWithContent = Union(cellsWithContent, .SpecialCells(xlCellTypeFormulas))
On Error GoTo 0
End With
'Early exit; return Nothing if there is no Data
If cellsWithContent Is Nothing Then Exit Function
'Next, loop over all the content cells and group their currentRegions
' This allows us to include some blank cells which are interspersed amongst the data
' It is faster to loop over areas rather than cell by cell since we merge all the CurrentRegions either way
Dim item As Range
Dim usedRegions As Range
For Each item In cellsWithContent.Areas
'Debug.Print "adding: "; item.Address, item.CurrentRegion.Address
If usedRegions Is Nothing Then
Set usedRegions = item.CurrentRegion 'expands "item" to include any surrounding non-blank data
Else
Set usedRegions = Union(usedRegions, item.CurrentRegion)
End If
Next item
'Debug.Print cellsWithContent.Address; "->"; usedRegions.Address
Set ContentRange = usedRegions
End Function
Used like:
Debug.Print ContentRange(Sheet1).Address '$A$1:$F$22
Debug.Print ContentRange(Sheet2).Address '$A$1:$F$22,$N$5:$M$7
The result is a Range object containing 1 or more Areas, each of it which will represent a data/formula containing region on the sheet.
It is the same technique as clicking in all the cells in your sheet and pressing Ctrl+T, merging all those areas. I'm using it to find potential tables of data

Resources