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.
Related
I am trying to search Sheet1 column a for the string " Testing Test" (yes with the spaces beforehand) then copy all rows below the row containing this string until a blank row is found, then I want to paste this selected range into column A row 1 on Sheet2. Next I want to search for the string " CASH" (again yes with the spaces beforehand) and i want to copy just the row that includes that to be pasted 2 rows underneath the last row of the first range pasted.
Here is what I have so far, which does not work... I do not even address the second component of finding the second string because i can't get the first... please assist, not sure why this is not working:
Sub Test()
Dim StringToFind As String
Dim i As Range
Dim cell As Range
StringToFind = " Testing Test"
With Worksheets("Sheet1")
Set cell = .Rows(1).Find(What:=StringToFind, lookat:=xlWhole, _
MatchCase:=False, searchformat:=False)
If Not cell Is Nothing Then
For Each i In .Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp))
If IsNumeric(i.Value) Then
If i.Value > 0 Then
i.EntireRow.Copy
Sheets("sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial
End If
End If
Next i
Else
End If
End With
End Sub
Your question lacks a little detail. However, the code below will point you in the right direction. If you need help to manage it, please ask.
Sub FindAndCopy()
' 221
Dim WsS As Worksheet ' Source
Dim WsT As Worksheet ' Target
Dim Caps() As String ' captions to find
Dim Fnd As Range ' found caption
Dim Tgt As Range ' Target
Dim Arr As Variant ' Value of Fnd
Dim f As Integer ' loop counter: Caps
With ThisWorkbook
Set WsS = .Worksheets("Sheet1") ' change to suit
Set WsT = .Worksheets("Sheet2") ' change to suit
End With
Caps = Split("Testing Test,CASH", ",") ' extend to suit
For f = 0 To UBound(Caps)
Set Fnd = WsS.Rows(1).Find(Caps(f), LookIn:=xlValues, LookAt:=xlPart, _
MatchCase:=False, SearchFormat:=False)
If Fnd Is Nothing Then Exit For
Set Fnd = Fnd.Offset(1)
If f = 0 Then Set Fnd = Fnd.Resize(Fnd.End(xlDown).Row - 1, 1)
Arr = Fnd.Value ' copies Values, not Formulas
With WsT
Set Tgt = .Cells(1, 1)
If f Then Set Tgt = Tgt.Offset(.Cells(.Rows.Count, 1).End(xlUp).Row + 1)
If VarType(Arr) >= vbArray Then
Tgt.Resize(UBound(Arr), UBound(Arr, 2)).Value = Arr
Else
Tgt.Value = Arr
End If
End With
Next f
End Sub
Observe that I discarded the leading spaces in your search criteria in favour of looking for a partial match in the Find function. In that way it doesn't matter how many spaces there are but it may cause confusion if there several matches. In that case you might reinstate the blanks by amending the array of Caps.
I'm currently reorganizing some columns using VBA code and I need to make a change to one of the header rows and the values in 1 specific column. I've included what I'm basically trying to do in a comment. Here is the code I'm using but very cut down for brevity.
Sub columnOrder2()
Dim search As Range
Dim cnt As Integer
Dim colOrdr As Variant
Dim indx As Integer
colOrdr = Array("User name", "LanID", "Asset Tag")
cnt = 1
For indx = LBound(colOrdr) To UBound(colOrdr)
Set search = Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
' If search = "LanID" then change header row to "Last3"
' and return only the last 3 characters for values in cells
If Not search Is Nothing Then
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx
End Sub
Currently, I'm just running the code and manually renaming the column then creating a formula in cell g2 and using =Right(G2,3) and copying it down to the rest of the cells in column C. I know VBA can do this much better and maybe even just in a separate function. Any help would be appreciated. I haven't worked with Excel VBA for awhile now.
Assuming you mean to overwrite the LANId column with its own last three characters, you could code as follows (C2 instead of G2 in your question?):
Modified code close to OP
Includes a fully qualified (worksheet) range reference, btw (as otherwise VBA assumes any currently active worksheet) :-)
Sub columnOrder2()
Dim ws As Worksheet: Set ws = Sheet1 ' << Using e.g. the sheet's Code(Name)
Dim colOrdr As Variant
colOrdr = Array("User name", "LanID", "Asset Tag")
Dim cnt As Long
cnt = 1
Dim indx As Long
For indx = LBound(colOrdr) To UBound(colOrdr)
Dim search As Range
Set search = ws.Rows("1:1").Find(colOrdr(indx), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
If Not search Is Nothing Then
If LCase(search.Text) = "lanid" Then
'set column range object to memory
Dim rng As Range
Set rng = getColRange(ws, search.Column, Startrow:=1)
'return only the last 3 characters
rng.Value = Evaluate("=Right(" & rng.Address & ",3)")
'change header cell from "LANId" to "Last3"
rng(1, 1) = "Last3" ' change header from LANId to Last3
End If
If search.Column <> cnt Then
search.EntireColumn.Cut
Columns(cnt).Insert Shift:=xlToRight
Application.CutCopyMode = False
End If
cnt = cnt + 1
End If
Next indx
End Sub
Help function
Returns the range of a given sheet column up to the last row with a value:
Function getColRange(mySheet As Worksheet, _
Optional ByVal myColumn As Variant = "A", _
Optional ByVal Startrow As Long = 1) As Range
With mySheet
'a) change numeric column number to letter(s)
If IsNumeric(myColumn) Then myColumn = Split((.Columns(myColumn).Address(, 0)), ":")(0)
'b) get last row in given column
Dim lastRow As Long
lastRow = .Range(myColumn & .Rows.Count).End(xlUp).Row
'c) return data range as function result
' (a Range is an Object and has to be SET!)
Set getColRange = .Range(myColumn & Startrow & ":" & myColumn & lastRow)
End With
End Function
Related link
Instead of moving entire columns one after the other you might be interested in an array approach - c.f. Delete an array column and change position of two columns
I am trying to create a macro in excel 2010 that finds every cell in a sheet with a value of "All Customers." Every time that value is found I need a blank row inserted below it. Thought it would be pretty simple but I have searched I many forums and tried to use some sample code and I can't get it to work properly. I am a complete newb when it comes to VBA stuff. Thought I would post here and go do some light reading on basics of VBA.
If anyone has any good training resources, please post those as well.
Thanks in advance!
EDIT: In my OP, I neglected to mention that any row that contains a value of "All Customers" would ideally be highlighted and put in bold, increased size font.
These actions are something that an old Crystal Report viewing/formatting program used to handle automatically when pulling the report. After we upgraded the program I learned that this type of formatting ability had been removed with the release of the newer version of the program, according to the software manufacturer's tech support. Had this been defined in the release notes I would have not performed the upgrade. Regardless, that is how I found myself in this macro disaster.
Something like this code adpated from an article of mine here is efficient and avoids looping
It bolds and increase the font size where the text is found (in the entire row, as Tim points out you should specify whether you meant by cell only)
It adds a blank row below the matches
code
Option Explicit
Const strText As String = "All Customers"
Sub ColSearch_DelRows()
Dim rng1 As Range
Dim rng2 As Range
Dim rng3 As Range
Dim cel1 As Range
Dim cel2 As Range
Dim strFirstAddress As String
Dim lAppCalc As Long
Dim bParseString As Boolean
'Get working range from user
On Error Resume Next
Set rng1 = Application.InputBox("Please select range to search for " & strText, "User range selection", ActiveSheet.UsedRange.Address(0, 0), , , , , 8)
On Error GoTo 0
If rng1 Is Nothing Then Exit Sub
'Further processing of matches
bParseString = True
With Application
lAppCalc = .Calculation
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With
'a) match string to entire cell, case insensitive
'Set cel1 = rng1.Find(strText, , xlValues, xlWhole, xlByRows, , False)
'b) match string to entire cell, case sensitive
'Set cel1 = rng1.Find(strText, , xlValues, xlWhole, xlByRows, , True)
'c)match string to part of cell, case insensititive
Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , False)
'd)match string to part of cell, case sensititive
' Set cel1 = rng1.Find(strText, , xlValues, xlPart, xlByRows, , True)
'A range variable - rng2 - is used to store the range of cells that contain the string being searched for
If Not cel1 Is Nothing Then
Set rng2 = cel1
strFirstAddress = cel1.Address
Do
Set cel1 = rng1.FindNext(cel1)
Set rng2 = Union(rng2.EntireRow, cel1)
Loop While strFirstAddress <> cel1.Address
End If
'Further processing of found range if required
If bParseString Then
If Not rng2 Is Nothing Then
With rng2
.Font.Bold = True
.Font.Size = 20
.Offset(1, 0).EntireRow.Insert
End With
End If
End If
With Application
.ScreenUpdating = True
.Calculation = lAppCalc
End With
End Sub
Public Sub InsertRowAfterCellFound()
Dim foundRange As Range
Set foundRange = Cells.Find(What:="yourStringOrVariant", After:=ActiveCell) 'Find the range with the occurance of the required variant
Rows(foundRange.Row + 1 & ":" & foundRange.Row + 1).Insert 'Insert a new row below the row of the foundRange row
foundRange.Activate 'Set the found range to be the ActiveCell, this is a quick and easy way of ensuring you aren't repeating find from the top
End Sub
You may need to add error handling to the code as you will get an error if no cell with the specified value is found.
Assuming this is on the first sheet ("sheet 1"), here is a slow answer:
Sub InsertRowsBelowAllCustomers()
'Set your worksheet to a variable
Dim sheetOne as Worksheet
Set sheetOne = Worksheets("Sheet1")
'Find the total number of used rows and columns in the sheet (where "All Customers" could be)
Dim totalRows, totalCols as Integer
totalRows = sheetOne.UsedRange.Rows.Count
totalCols = sheetOne.UsedRange.Columns.Count
'Loop through all used rows/columns and find your desired "All Customers"
Dim row, col as Integer
For row = 1 to totalRows
For col = 1 to totalCols
If sheetOne.Cells(row,col).Value = "All Customers" Then
Range(sheetOne.Cells(row,col)).Select
ActiveCell.Offset(1).EntireRow.Insert
totalRows = totalRows + 1 'increment totalRows because you added a new row
Exit For
End If
Next col
Next row
End Sub
This function starts from the last row and goes back up to the first row, inserting an empty row after each cell containing "All Customers" on column A:
Sub InsertRowsBelowAllCustomers()
Dim R As Integer
For R = UsedRange.Rows.Count To 1 Step -1
If Cells(R, 1) = "All Customers" Then Rows(R + 1).Insert
Next R
End Sub
The error is because the worksheet was not specified in used range.
I have slightly altered the code with my text being in column AJ and inserting a row above the cell.
Dim R As Integer
For R = ActiveSheet.UsedRange.Rows.Count To 1 Step -1
If Range("AJ" & R) = "Combo" Then Rows(R).Insert
Next R
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