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

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.

Related

For each loop does not operate as expected

I have two sheets in excel, one is a board with several cells with numbers inside, and the other is references (that have the numbers in previous board) and i need to write in same line of the references where are the cells located.
image of the first board where are the references
image of the excel sheet that i have to write the location of each reference
my vba code
Example:
The arm8.png is the board and local.png is where i write de localizations of the cells
Option Explicit
Sub ciclo()
Dim FindString As String
Dim Rng As Range
Dim matrixVal As Range
Set matrixVal = Sheets("Localizações").Range("B1")
FindString = matrixVal
For Each Rng In matrixVal
If Trim(FindString) <> "" Then
With Sheets("Arm8").Range("A1:J10")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
'Application.Goto Rng, False
'MsgBox Rng.Column & " - " & Rng.Row
Else
MsgBox "Nothing found"
End If
End With
With Sheets("Localizações")
.Range("C1:C9").Value = Rng.Column
.Range("D1:D9").Value = Rng.Row
End With
End If
Next Rng
End Sub
I expected the output in local.png to be column C and D
2 - 9
2 - 7
2 - 8
2 - 4
5 - 4
7 - 4
5 - 9
9 - 7
9 - 0
Firstly, as I said in my comment, this:
Set matrixVal = Sheets("Localizações").Range("B1")
sets matrixVal as one single cell (B1 to be precise), so your For-Each loop doesn't have any cells to loop through apart from this single cell, so it will only run once.
Second, the FindString needs to be updated inside the loop, otherwise you'll be searching for the same value over and over.
Finally, you shouldn't update the Rng variable inside the loop because you are already using it to loop through a range. You need a second variable of type Range.
Your code should look like:
Sub ciclo()
Dim FindString As String
Dim Rng As Range
Dim cell As Range
Dim matrixVal As Range
Set matrixVal = ThisWorkbook.Worksheets("Localizacoes").Range("B1:B9")
For Each cell In matrixVal
FindString = cell.Value
If Trim(FindString) <> "" Then
With ThisWorkbook.Worksheets("Arm8").Range("A1:J10")
Set Rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
With ThisWorkbook.Worksheets("Localizacoes")
.Cells(cell.Row, "C").Value = Rng.Column
.Cells(cell.Row, "D").Value = Rng.Row
End With
Else
MsgBox "Nothing found"
End If
End With
End If
Next cell
End Sub

VBA Excel 2007 change Macro to search using a range instead of putting the data in the macro

I found a macro that suits my needs but it isn't really efficient. I have a 6,000 row list of addresses I need to ID using data from another spreadsheet. I've been copying the data I need to search for into the ADDRESSES2SEARCH part of the macro and changing OWNERNAME used to ID them. I would like to be able to use either a named range or column from the other spreadsheet as the ADDRESSES2SEARCH. Unfortunately I don't really know enough about VBA to change this macro to do that. Would anyone be able to help or point me in the right direction?
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
MyArr = Array( ADDRESSES2SEARCH )
With Sheets("Adhoc Boundary Scan").Range("A:A")
.Offset(0, 1).ClearContents
For I = LBound(MyArr) To UBound(MyArr)
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rng.Offset(0, 1).Value = OWNERNAME
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
What I ended up with using Autofilter
Sub FilterByCompany()
Dim vOwnerIPs As Variant
Dim wsScan As Worksheet
Dim wsVLANs As Worksheet
Dim rngOwnerIPs As Range
Dim rngScanIPs As Range
Set wsScan = Worksheets("Scan")
Set wsVLANs = Workbooks("VLANs.xlsx").Worksheets("Sheet1")
Set rngScanIPs = wsScan.Range("$A$1").CurrentRegion
'search CompanyA
Set rngOwnerIPs = wsVLANS.Range("CompanyArange")
vOwnerIPs = rngOwnerIPs.Value
rngScanIPs.AutoFilter _
Field:=1, _
Criteria1:=Application.Transpose(vOwnerIPs), _
Operator:=xlFilterValues
Intersect(rngScanIPs.EntireRow, wsScan.Range("B:B")).Value = "CompanyA"
'search CompanyB
Set rngOwnerIPs = wsVLANs.Range("CompanyBrange")
vOwnerIPs = rngOwnerIPs.Value
rngScanIPs.AutoFilter _
Field:=1, _
Criteria1:=Application.Transpose(vOwnerIPs), _
Operator:=xlFilterValues
Intersect(rngScanIPs.EntireRow, wsScan.Range("B:B")).Value = "CompanyB"
End Sub

Delete rows in Excel using VBA by finding column and value within column

I am trying to build a macro which will find a column with the header "Total Labor" and delete all rows which have "0" in that column. I am generating multiple reports and the "Total Labor" column will change position so that's why I need the find. So far I have this code but when I run it nothing happens. Any help is appreciated.
Sub DeleteRows()
Dim FoundCell As Range
Dim rng As Range
Application.ScreenUpdating = False
Set rng = Worksheets(ActiveSheet.Name).Range("A1:BB100").Find(what:="Total Labor", _
LookAt:=xlWhole, MatchCase:=False)
Set FoundCell = rng.Find(what:="0")
Do Until FoundCell Is Nothing
FoundCell.EntireRow.Delete
Set FoundCell = rng.FindNext
Loop
End Sub
First: if you set Application.ScreenUpdating = False be sure that you reset it to True before the sub ends. If your macro crashes you could find yourself unable to work with the application until you restart Excel or run another macro that sets Application.ScreenUpdating = True
Now, to answer your question: The problem with your code is that rng as defined in your code is only going to be the cell containing "Total Labor". When you search for a value of "0" in that range, the line Set FoundCell = rng.Find(what:="0") evaluates to "Nothing", so when you start the do loop, it meets the criterion of FoundCell Is Nothing and immediately goes to End Sub.
Something like this should do the trick:
Sub DeleteRows2()
On Error GoTo ErrorHandler
Application.ScreenUpdating = False
'~~>dim variables and set initial values
Dim rTotalLaborHeader As Range
Set rTotalLaborHeader = Worksheets(ActiveSheet.Name).Range("A1:BB100").Find(what:="Total Labor", _
LookAt:=xlWhole, MatchCase:=False)
Dim rTotalLaborColumn As Range
Set rTotalLaborColumn = Range(Cells(2, rTotalLaborHeader.Column), Cells(1048576, rTotalLaborHeader.Column).End(xlUp))
'Set rTotalLaborColumn = Range(rTotalLaborHeader.Offset(1, 0), rTotalLaborHeader.End(xlDown))
Dim rLaborRow As Range
'~~>Loop to delete rows with zero Total Labor
For Each rLaborRow In rTotalLaborColumn
If rLaborRow.Value = 0 Then rLaborRow.EntireRow.Delete
Next rLaborRow
CleanupAndExit:
Application.ScreenUpdating = True
Exit Sub
ErrorHandler:
Resume CleanupAndExit
End Sub
How about:
Sub DeleteRow()
Dim colly As Long, killer As Range, nRow As Long
colly = 0
For i = 1 To Columns.Count
If Cells(1, i).Value = "Total Labor" Then
colly = i
Exit For
End If
Next i
If colly = 0 Then
MsgBox "Header not found"
Exit Sub
End If
nRow = Cells(Rows.Count, colly).End(xlUp).Row
For i = 1 To nRow
If Cells(i, colly).Value = 0 Then
If killer Is Nothing Then
Set killer = Cells(i, colly)
Else
Set killer = Union(killer, Cells(i, colly))
End If
End If
Next i
If killer Is Nothing Then
Else
killer.EntireRow.Delete
End If
End Sub
You need to replicate the FindAll functionality that the Excel UI Provides. Here's a code-list for achieving that in VBA. Save this to a .bas file, then call it in your macro after you locate 'Total Labor' and then look through the range you get back from FindAll and execute .Delete on them.
Sub DeleteRows()
Dim FoundCell As Range
Dim rng As Range
Application.ScreenUpdating = False
Set rng = Worksheets(ActiveSheet.Name).Range("A1:BB100").Find(what:="Total Labor", _
LookAt:=xlWhole, MatchCase:=False)
If rng Is Nothing Then
Msgbox "Total Labor Not Found"
Else
Set SearchRange = rng.EntireColumn
FindWhat = "0"
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
Debug.Print "Value Not Found"
Else
For Each FoundCell In FoundCells
FoundCell.EntireRow.Delete
Next FoundCell
End If
End If
End Sub
FindAll Source Code: http://www.cpearson.com/excel/findall.aspx
Function FindAll(SearchRange As Range, _
FindWhat As Variant, _
Optional LookIn As XlFindLookIn = xlValues, _
Optional LookAt As XlLookAt = xlWhole, _
Optional SearchOrder As XlSearchOrder = xlByRows, _
Optional MatchCase As Boolean = False, _
Optional BeginsWith As String = vbNullString, _
Optional EndsWith As String = vbNullString, _
Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result. If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
XLookAt = xlPart
Else
XLookAt = LookAt
End If
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
For Each Area In SearchRange.Areas
With Area
If .Cells(.Cells.Count).Row > MaxRow Then
MaxRow = .Cells(.Cells.Count).Row
End If
If .Cells(.Cells.Count).Column > MaxCol Then
MaxCol = .Cells(.Cells.Count).Column
End If
End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
after:=LastCell, _
LookIn:=LookIn, _
LookAt:=XLookAt, _
SearchOrder:=SearchOrder, _
MatchCase:=MatchCase)
If Not FoundCell Is Nothing Then
Set FirstFound = FoundCell
Do Until False ' Loop forever. We'll "Exit Do" when necessary.
Include = False
If BeginsWith = vbNullString And EndsWith = vbNullString Then
Include = True
Else
If BeginsWith <> vbNullString Then
If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
If EndsWith <> vbNullString Then
If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
Include = True
End If
End If
End If
If Include = True Then
If ResultRange Is Nothing Then
Set ResultRange = FoundCell
Else
Set ResultRange = Application.Union(ResultRange, FoundCell)
End If
End If
Set FoundCell = SearchRange.FindNext(after:=FoundCell)
If (FoundCell Is Nothing) Then
Exit Do
End If
If (FoundCell.Address = FirstFound.Address) Then
Exit Do
End If
Loop
End If
Set FindAll = ResultRange
End Function

Excel unique value query

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

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