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
Related
EDIT: I may have spotted an issue as soon as posting it the myRange
variables dont seem to be doing anything - so I'm feeling they were
there from a method i was using ages ago and there decided to crop out
I'll remove the whole myRange variable and see what happens
Set myRange = ActiveSheet.Range("1:1")
Set myRange = ActiveSheet.Range("A:A")
EDIT 2: Ok so changing the numCols and numRows functions to only use
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
numRows = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).row
They now return the correct row and Column numbers
But now when I run selectBlock() it gives me runtime error 28 "Out of Stack Space"
Hello All, I've been writing code to be able to go through multiple sheets and copy the data across to a master workbook
Im coding this to work on any file depending what you pass to it - which has been fine
What im having problems with is the Functions I have made which find the last populated row for any sheet I pass to it
Sub test()
selectBlock().Select
End Sub
Function selectBlock() As Range
Dim row As Integer: row = numRows() 'Finds last populated row
Dim col As Integer: col = numCols() 'Finds last populated column
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
'sets this area starting from cell A2 as the Range
End Function
Function numCols() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("1:1") 'Checks first row to see how many populated columns there are
numCols = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Integer
Dim myRange As Range
Set myRange = ActiveSheet.Range("A:A") 'Checks first columns to see how many populated rows there are
numRows = Range("A" & Rows.Count).End(xlUp).row
End Function
When I call the test Sub it causes Excel to hang then crash with no error code
So i imagine im creating some kind of loop or critical error that isnt handled by excel very well
Any help with this would be really appreciated
I can also understand if how im going about it is incredibly stupid
I used to code in Java and maybe im using techniques or pitfalls that I never got rid of - Im self taught at VBA like most and so never learnt official coding practices for VBA
Lot of things here
Fully qualify your cells
Use Long and not Integer when working with row and columns
Use error handling. This will avoid the Excel crashing.
Try this
Sub test()
On Error GoTo Whoa
selectBlock().Select
Exit Sub
Whoa:
MsgBox Err.Description
End Sub
Function selectBlock() As Range
Dim row As Long: row = numRows() 'Finds last populated row
Dim col As Long: col = numCols() 'Finds last populated column
Set selectBlock = ActiveSheet.Range("A2:" & ActiveSheet.Cells(row, col).Address)
End Function
Function numCols() As Long
numCols = ActiveSheet.Cells(1, ActiveSheet.Columns.Count).End(xlToLeft).Column
End Function
Function numRows() As Long
numRows = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).End(xlUp).row
End Function
Replace
Set selectBlock() = Range("A2:" & Cells(row, col).Address)
to
Set selectBlock = Range("A2:" & Cells(row, col).Address)
it looks recursive :P
There are safer ways to find the LastRow and LastCol, I like the Find function.
See more detailed in my code's comments.
Code
Sub test()
Dim Rng As Range
Set Rng = selectBlock
Rng.Select '<-- Not sure why you need to Select ?
End Sub
'============================================================
Function selectBlock() As Range
Dim LastRow As Long
Dim LastCol As Long
LastRow = FindLastRow(ActiveSheet) 'Finds last populated row
LastCol = FindLastCol(ActiveSheet) 'Finds last populated column
Set selectBlock = Range(Cells(2, "A"), Cells(LastRow, LastCol))
End Function
'============================================================
Function FindLastCol(Sht As Worksheet) As Long
' This Function finds the last col in a worksheet, and returns the column number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastCol = LastCell.Column
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
'============================================================
Function FindLastRow(Sht As Worksheet) As Long
' This Function finds the last row in a worksheet, and returns the row number
Dim LastCell As Range
With Sht
Set LastCell = .Cells.Find(What:="*", After:=.Cells(1), Lookat:=xlPart, LookIn:=xlFormulas, _
SearchOrder:=xlByRows, SearchDirection:=xlPrevious, MatchCase:=False)
If Not LastCell Is Nothing Then
FindLastRow = LastCell.row
Else
MsgBox "Error! worksheet is empty", vbCritical
End
End If
End With
End Function
I am working with the following VBA code, with summarizes some survey results :
Sub Main()
ReplaceBlanks
Multi_FindReplace
End Sub
Sub ReplaceBlanks()
Dim ws As Worksheet
Dim lastrow As Long
Dim rng As Range
Set ws = Sheets("Refined")
lastrow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastrow
If WorksheetFunction.CountA(ws.Range(ws.Cells(i, 17), ws.Cells(i, 21))) = 0 Then
If Not rng Is Nothing Then
Set rng = Union(ws.Cells(i, 1), rng)
Else
Set rng = ws.Cells(i, 1)
End If
End If
Next i
rng.EntireRow.Delete
End Sub
Sub Multi_FindReplace()
'PURPOSE: Find & Replace a list of text/values throughout entire workbook
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault
Dim fndList As Variant
Dim rplcList As Variant
Dim x As Long
fndList = Array("Mostly satisfied", "Completely satisfied", "N/A", "Not at all satisfied")
rplcList = Array("Satisfied", "Satisfied", "Satisfied", "Not satisfied")
Set sht = ActiveWorkbook.Sheets("Refined")
'Loop through each item in Array lists
For x = LBound(fndList) To UBound(fndList)
'Loop through each worksheet in ActiveWorkbook
sht.Cells.Replace What:=fndList(x), Replacement:=rplcList(x), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, _
SearchFormat:=False, ReplaceFormat:=False
Next x
End Sub
This code produces output that shows only the phrases "Satisfied" or "Not Satisfied." The picture below shows how it look :
However, when it's finished it also shows some blank cells, which I would like to also say "Satisfied " ( but we only want to do this after removing the empty lines where survey respondents didn't answer any question at all (this is accomplished already by the "ReplaceBlanks" sub-function ) .
The blank cells I want to focus on are only those that are in columns Q3 to U3 , then W3 to Z3 , and finally AB3 to AC3 downward ( i.e I don't know how many rows there will be in those columns, but at least one and starting at row 3. )
I am not sure about how to focus only on those 3 groups of columns, but I tried the following code on the first group :
Sub dural()
Dim r As Range, LastRow As Long
LastRow = Cells(Rows.Count, 2).End(xlUp).Row
For Each r In Range("Q3:U19" & LastRow)
If r.Text = "" Then r.Value = "Satisfied"
Next r
End Sub
but this one put "Satisfied" in an extra thousand rows below the group which I needed !!
Any tips appreciated, thanks
try this:
Sub dural()
With Sheets("Refined")
Intersect(.UsedRange, .Range("Q:U, W:Z, AB:AC")).SpecialCells(xlCellTypeBlanks).Value = "Satisfied"
End With
End Sub
BTW: "Q3:U19" & LastRow is bound to return some "Q3:Q19xxx" address, with xxx being equal to LastRow...
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.
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
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