Good morning,
I am trying to narrow down my find all search option in VBA Excel.
The original example comes from this link:
https://www.excelcampus.com/tools/find-all-vba-form-for-excel/
where you can download the files with the find all tool both for active worksheet as well as a whole workbook.
I would like to set it in the custom worksheet instead of the active one.
According to the hint based in the comment:
Go to line 46 in the code “Set SearchRange =
ActiveSheet.UsedRange.Cells”
6. Change this to “Set SearchRange = ActiveSheet.Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))”
https://www.excelcampus.com/wp-content/uploads/2013/06/Find-All-Form-Search-1st-Column.png
I should only replace the SearchRange variable.
I did it, making my whole code like this:
Sub FindAllMatches()
'Find all matches on activesheet
'Called by: TextBox_Find_KeyUp event
Dim SearchRange As Range
Dim FindWhat As Variant
Dim FoundCells As Range
Dim FoundCell As Range
Dim arrResults() As Variant
Dim lFound As Long
Dim lSearchCol As Long
Dim lLastRow As Long
If Len(f_FindAll.TextBox_Find.Value) > 1 Then 'Do search if text in find box is longer than 1 character.
Set SearchRange = Sheets("Tracker").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
'Set SearchRange = Activesheet.UsedRange.Cells - original input
FindWhat = f_FindAll.TextBox_Find.Value
'Calls the FindAll function
Set FoundCells = FindAll(SearchRange:=SearchRange, _
FindWhat:=FindWhat, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
MatchCase:=False, _
BeginsWith:=vbNullString, _
EndsWith:=vbNullString, _
BeginEndCompare:=vbTextCompare)
If FoundCells Is Nothing Then
ReDim arrResults(1 To 1, 1 To 2)
arrResults(1, 1) = "No Results"
Else
'Add results of FindAll to an array
ReDim arrResults(1 To FoundCells.Count, 1 To 2)
lFound = 1
For Each FoundCell In FoundCells
arrResults(lFound, 1) = FoundCell.Value
arrResults(lFound, 2) = FoundCell.Address
lFound = lFound + 1
Next FoundCell
End If
'Populate the listbox with the array
Me.ListBox_Results.List = arrResults
Else
Me.ListBox_Results.Clear
End If
End Sub
I am getting the following error:
Application-defined or object-defined error
pointing exactly the line, which was changed:
Set SearchRange = Sheets("Tracker").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
Everything is alright when the one looks like this:
Set SearchRange = Sheets("Tracker").UsedRange.Cells
so I don't know where might be the problem.
From the thread here:
VBA Runtime Error 1004 "Application-defined or Object-defined error" when Selecting Range
I can guess, that my form is placed in the wrong worksheet (as you can see on the image above).
In this event I tried to change the 93rd line of code:
ActiveSheet.Range(strAddress).Select
to
Sheets("Tracker").Range(strAddress).Select
but the result is exactly the same.
I also tried to set the different range for my cells:
Set SearchRange = Sheets("Tracker").Range(Cells(4, 1), Cells(Rows.Count, 1).End(xlUp))
as my data starts from the column A4. Unfortunately still no result.
I believe, that my problem starts from the .Range statement. When I change the .Range to .Usedrange
then my error is:
Wrong number of arguments or invalid property assignment
Can anyone help me to solve this issue? I appreciate any help.
The only thing I can see is that the rowcount is done on the active sheet instead of the sheet 'tracker'
try changing
Set SearchRange = Sheets("Tracker").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
to
With Sheets("Tracker")
Set SearchRange = .Range(.Cells(1, 1), .Cells(1, .Cells(1, .Rows.Count).End(xlUp).Row))
End With
edit 5-6-2020 tested the code and realised that the format was incorrect.
We can alternatively set the fixed range instead and see this problem off
In place of
Set SearchRange = Sheets("Tracker").Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
We can input
Set SearchRange = Sheets("Tracker").Range("A4:A4000")
However, it obligates us to take control of our range and keep the code updated as the amount our records is expanded.
Related
Trying to set a Range ("headers") that is from a cell containing "Period" to cell containing "Agent Split". At the end of the code I select all of these ranges to make sure it's working properly.
I had tweaked the following code that contained a For loop
Sub Rangeheaders_test()
Dim r As Long
Dim endRow As Long
Dim endCell As Range
Dim headers As Range
With ActiveSheet
endRow = 500
For r = 1 To endRow
If .Cells(r, "A").Value = "Period" Then
Set endCell = .Rows(r).Find(What:="Agent Split", LookIn:=xlValues,_
LookAt:=xlPart, After:=.Cells(r, "A"))
Set headers = .Range(.Cells(r, "A"), endCell)
End If
Next r
End With
headers.Select
End Sub
However this code ran through the ranges and only selected the last when I wish to select them ALL in order to test it. So I deleted the loop which left me with the following
With ActiveSheet
endRow = 500
r = 1 To endRow
If .Cells(r, "A").Value = "Period" Then
Set endCell = .Rows(r).Find(What:="Agent Split", LookIn:=xlValues,_
LookAt:=xlPart, After:=.Cells(r, "A"))
Set headers = .Range(.Cells(r, "A"), endCell)
End If
End With
headers.Select
But now I'm either getting a Syntax Error or Compile error for Unexpected With or If close and I'm stuck. Do I need to define the Then condition? Is the If Then statement even necessary? Is there another way i can set the conditions?
I realized from #Jun 's insightful comment that i was trying to store multiple ranges in one variable and that's where i was going wrong.
After some research i found the Union method where I'm able to combine my ranges after i specify them -- which i did using the .Findnext method
Sub findheader()
Dim startcell As Range
Dim rng As Range
Set rng = Range("A1:A500")
Set startcell = rng.Find(what:="Period", LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlNext, MatchCase:=False)
Dim header1, header2, header3 As Range
Set header1 = Range(startcell, startcell.End(xlToRight))
Set startcell = rng.FindNext(startcell)
Set header2 = Range(startcell, startcell.End(xlToRight))
Set startcell = rng.FindNext(startcell)
Set header3 = Range(startcell, startcell.End(xlToRight))
Dim headers As Range
Set headers = Union(header1, header2, header3)
headers.Select
End Sub
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
Hey I'm currently writing a macro in VBA (which I'm quite new at). The macro looks at a spreadsheet and finds specific column headers. It then clears the contents of any cell containing a zero. This part of my code works exactly how I want, the only issue is that it does not hand multiple occurrences of the column header...so it finds the first header, clears the contents, and ignores the second occurrence. I have tried multiple avenues whether it be looping to find it or using the .FindNext function. Any help would be appreciated. Thank you! My code is posted below:
Sub DeleteRows2()
Application.ScreenUpdating = True
Dim lastrow As Long
With ActiveSheet
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
'~~>Start of First Instance
'~~>dim variables and set initial values
Dim delaymaxheader As Range
Set delaymaxheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="DELAY Spec Max", LookAt:=xlWhole, MatchCase:=False)
Dim delaymaxcolumn As Range
Set delaymaxcolumn = Range(Cells(5, delaymaxheader.Column), Cells(lastrow, delaymaxheader.Column))
'Set delaymaxcolumn = Range(delaymaxheader.Offset(1, 0), delaymaxheader.End(xlDown))
'~~>dim variables and set initial values
Dim delayminheader As Range
Set delayminheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="DELAY Spec Min", LookAt:=xlWhole, MatchCase:=False)
Dim delaymincolumn As Range
Set delaymincolumn = Range(Cells(5, delayminheader.Column), Cells(lastrow, delayminheader.Column))
'Set delaymincolumn = Range(delayminheader.Offset(1, 0), delayminheader.End(xlDown))
'~~>dim variables and set initial values
Dim phasemaxheader As Range
Set phasemaxheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="PHASE Spec Max", LookAt:=xlWhole, MatchCase:=False)
Dim phasemaxcolumn As Range
Set phasemaxcolumn = Range(Cells(5, phasemaxheader.Column), Cells(lastrow, phasemaxheader.Column))
'Set phasemaxcolumn = Range(phasemaxheader.Offset(1, 0), phasemaxheader.End(xlDown))
'~~>dim variables and set initial values
Dim phaseminheader As Range
Set phaseminheader = Worksheets(ActiveSheet.Name).Range("A4:Z4").Find(what:="PHASE Spec Min", LookAt:=xlWhole, MatchCase:=False)
Dim phasemincolumn As Range
Set phasemincolumn = Range(Cells(5, phaseminheader.Column), Cells(lastrow, phaseminheader.Column))
'Set phasemincolumn = Range(phaseminheader.Offset(1, 0), phaseminheader.End(xlDown))
'~~>Loop to delete rows with zero
'~~>Dim delaycount(5 To lastrow) As Integer
For i = 5 To lastrow
If Cells(i, delaymaxheader.Column) = 0 Then
Cells(i, delaymaxheader.Column).ClearContents
End If
If Cells(i, delayminheader.Column) = 0 Then
Cells(i, delayminheader.Column).ClearContents
End If
If Cells(i, phasemaxheader.Column) = 0 Then
Cells(i, phasemaxheader.Column).ClearContents
End If
If Cells(i, phaseminheader.Column) = 0 Then
Cells(i, phaseminheader.Column).ClearContents
End If
Next i
End Sub
You need to use the FindNext method to keep going (https://msdn.microsoft.com/en-us/library/office/ff839746.aspx)
LastRow is only the last row of column A though - what happens if another column goes further?
Also Worksheets(ActiveSheet.Name).Range("A4:Z4") is the same as ActiveSheet.Range("A4:Z4").
Public Sub DeleteRows()
Dim colAllRanges As Collection
Dim colHeadings As Collection
'Declared as variants as they're used to step through the collection.
Dim vHeading As Variant
Dim vRange As Variant
Dim vCell As Variant
Dim rDelayMaxHeader As Range
Dim sFirstAddress As String
Dim lLastRow As Long
With ActiveSheet
lLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Set colAllRanges = New Collection
Set colHeadings = New Collection
colHeadings.Add "DELAY Spec Max"
colHeadings.Add "DELAY Spec Min"
colHeadings.Add "PHASE Spec Max"
colHeadings.Add "PHASE Spec Min"
For Each vHeading In colHeadings
With ActiveSheet.Range("A4:Z4")
'Find the first instance of the heading we're looking for.
Set rDelayMaxHeader = .Find(What:=vHeading, LookIn:=xlValues, LookAt:=xlWhole)
If Not rDelayMaxHeader Is Nothing Then
sFirstAddress = rDelayMaxHeader.Address
Do
'Resize the range from heading to last row and add it to the collection.
colAllRanges.Add rDelayMaxHeader.Resize(lLastRow - rDelayMaxHeader.Row + 1, 1)
'Find the next occurrence.
Set rDelayMaxHeader = .FindNext(rDelayMaxHeader)
'Keep going until nothings found or we loop back to the first address again.
Loop While Not rDelayMaxHeader Is Nothing And rDelayMaxHeader.Address <> sFirstAddress
End If
End With
Next vHeading
'Now to go through each cell in the range we've added to the collection and check for 0's.
For Each vRange In colAllRanges
For Each vCell In vRange
If vCell = 0 Then
vCell.ClearContents
End If
Next vCell
Next vRange
End Sub
With the above method you can add extra columns if needed - just add another colHeadings.Add "My New Column Header" row in the code.
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.
To be quite honest I am not entirely sure how to describe what it is I am trying to accomplish? But, here it goes anyway. I have an excel sheet containing one column of IDs and a second column of values that need to be associated to the first column. The problem is that the IDs in column A contain duplicates, which is okay because one ID can qualify for multiple values. What I need is to have a third column pull back the unique id, and a fourth column pull back a semi-colon delimited list of all of the values the id qualifies for. Hopefully the attached image makes sense? For what it's worth I have tried every formula I can think of, and I really know nothing about macros, which is what I am thinking needs to be implemented.
Try below code :
Sub sample()
Dim lastRowA As Long, lastRowC As Long
lastRowA = Range("A" & Rows.Count).End(xlUp).Row
lastRowC = Range("C" & Rows.Count).End(xlUp).Row
Dim rng As Range, cell As Range
Set rng = Range("C2:C" & lastRowC)
Dim rngSearch As Range
Set rngSearch = Range("A1:A" & lastRowA)
Dim rngFind As Range
Dim firstCell As String
For Each cell In rng
Set rngFind = rngSearch.Find(What:=cell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows)
If Not rngFind Is Nothing Then
temp = rngFind.Offset(0, 1)
firstCell = rngFind.Address
Do While Not rngFind Is Nothing
Set rngFind = rngSearch.FindNext(After:=rngFind)
If rngFind.Address <> firstCell Then
temp = temp & ";" & rngFind.Offset(0, 1)
Else
Set rngFind = Nothing
End If
Loop
End If
cell.Offset(0, 1) = temp
Next
End Sub
Here's an alternative approach, that has several advantages
it builkds the list of unique sku's
it clear old data from columns C:D
it will run much faster than looping over a range
Sub Demo()
Dim rngA As Range, rng as Range
Dim datA As Variant
Dim i As Long
Dim sh As Worksheet
Dim dic As Object
Set sh = ActiveSheet ' can change this to your worksheet of choice
Set dic = CreateObject("Scripting.Dictionary")
With sh
' Get data from columns A:B into a variant array
Set rngA = .Range(.Cells(2, 2), .Cells(.Rows.Count, 1).End(xlUp))
datA = rngA
' Create list of unique sku's and built value strings
For i = 1 To UBound(datA)
If dic.Exists(datA(i, 1)) Then
dic(datA(i, 1)) = dic(datA(i, 1)) & ";" & datA(i, 2)
Else
dic.Add datA(i, 1), datA(i, 2)
End If
Next
' Clear exisating data from columns C:D
Set rng = .Range(.Cells(2, 4), .Cells(.Rows.Count, 3).End(xlUp))
If rng.Row > 1 Then
rng.Clear
End If
' Put results into columns C:D
.Range(.Cells(2, 3), .Cells(dic.Count + 1, 3)) = Application.Transpose(dic.Keys)
.Range(.Cells(2, 4), .Cells(dic.Count + 1, 4)) = Application.Transpose(dic.Items)
End With
End Sub
How to add this:
Start the VBS editor (Alt+F11 from excel)
show project explorer, if its not already visible (Ctrl+R)
add a Module (right click on your workbook, Insert, Module)
open the module (dbl click)
Add Option Explicit as the first line, if not already there
copy paste this code into module
How to run it, from Excel
activate the sheet with your data
open macro dialog (Alt+F8)
select Demo from list and run