I want to break up this line of code, to make it more digestible, in smaller steps, but I am running in problems that I either get compile errors, run time errors, or just plain the wrong response.
As a beginner in coding of VBA, maybe somebody enlightens me, why it is not possible, or if it is possible where I am going wrong with my approach.
This code is functional snippet is below, but the function following is not
Dim WksN As String
Dim res As Object
' Set res = Sheets("Sheet3").Cells(1, 1).EntireRow.Find(What:=name
Set res = Sheets(WksN).Cells(1, 1).EntireRow.Find(What:=name _
, LookIn:=xlValues _
, LookAt:=xlPart _
, SearchOrder:=xlByColumns _
, SearchDirection:=xlPrevious _
, MatchCase:=False)
Public Function GetColumnNumber(ByVal WksN As String, _
ByVal name As String) As Long
Dim wks As Worksheet
Dim rng As Range
Dim res As Object
Dim clmn As Object
' Set wks = ActiveWorkbook.Worksheets(CStr(WksN))
' Set wks = Sheets(CStr(WksN))
' Set wks = Sheets(CStr(WksN)).Activate
' Set wks = ActiveWorkbook.Worksheets(CStr(WksN)).Activate
Set wks = ActiveWorkbook.Worksheets(CStr(WksN)) '
' Set rng = wks.Cells(1, 1).EntireRow.Select ' Run time error
' Set rng = wks.Activate ' Not needed ??
' Set rng = wks.Rows(1).Select ' Compile error
Set rng = wks.Rows(1)
' With wks.Cells(1, 1).EntireRow ' Didn't work
With rng
Set clmn = .Find(What:=name, _
LookIn:=xlValues, _
LookAt:=xlPart, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
End With
If res Is Nothing Then
GetColumnNumber = 0
Else
GetColumnNumber = clmn.Column
End If
End Function
I would like to set the range of the entire first row and then
search and find the column in which my string is stored.
I am not sure if the statement from above is atomic and can't be broken up,
or how I am not activating or selecting the "right" range, as the return value of this function is zero when the return value of the first code snippet is none zero and correct.
The second question I have that I seem not to select the range when I am using the .Rows(1) statement, which strikes me that I must fundamentally not understand how this is supposed to work.
Set rng = wks.Cells(1, 1).EntireRow.Select ' Run time error
Select does not return a value, so don't use that if you're trying to get a reference to a range
Set rng = wks.Cells(1, 1).EntireRow
This should work:
Public Function GetColumnNumber(ByVal WksN As String, _
ByVal hdr As String) As Long
Dim f As Range
Set f = ActiveWorkbook.Worksheets(WksN).Rows(1).Find( _
what:=hdr, LookIn:=xlValues, lookat:=xlPart)
If f Is Nothing Then
GetColumnNumber = 0
Else
GetColumnNumber = f.Column
End If
End Function
Related
I am trying to write a VBA routine that will take a string, search a given Excel workbook, and return to me all possible matches.
I currently have an implementation that works, but it is extremely slow as it is a double for loop. Of course the built in Excel Find function is "optimized" to find a single match, but I would like it to return an array of initial matches that I can then apply further methods to.
I will post some pseudocode of what I have already
For all sheets in workbook
For all used rows in worksheet
If cell matches search string
do some stuff
end
end
end
As previously stated, this double for loop makes things run very slowly, so I am looking to get rid of this if possible. Any suggestions?
UPDATE
While the below answers would have improved my method, I ended up going with something slightly different as I needed to do multiple queries over and over.
I instead decided to loop through all rows in my document and create a dictionary containing a key for each unique row. The value this points to will then be a list of possible matches, so that when I query later, I can simply just check if it exists, and if so, just get a quick list of matches.
Basically just doing one initial sweep to store everything in a manageable structure, and then query that structure which can be done in O(1) time
Using the Range.Find method, as pointed out above, along with a loop for each worksheet in the workbook, is the fastest way to do this. The following, for example, locates the string "Question?" in each worksheet and replaces it with the string "Answered!".
Sub FindAndExecute()
Dim Sh As Worksheet
Dim Loc As Range
For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(What:="Question?")
If Not Loc Is Nothing Then
Do Until Loc Is Nothing
Loc.Value = "Answered!"
Set Loc = .FindNext(Loc)
Loop
End If
End With
Set Loc = Nothing
Next
End Sub
Based on Ahmed's answer, after some cleaning up and generalization, including the other "Find" parameters, so we can use this function in any situation:
'Uses Range.Find to get a range of all find results within a worksheet
' Same as Find All from search dialog box
'
Function FindAll(rng As Range, What As Variant, Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, Optional SearchOrder As XlSearchOrder = xlByColumns, Optional SearchDirection As XlSearchDirection = xlNext, Optional MatchCase As Boolean = False, Optional MatchByte As Boolean = False, Optional SearchFormat As Boolean = False) As Range
Dim SearchResult As Range
Dim firstMatch As String
With rng
Set SearchResult = .Find(What, , LookIn, LookAt, SearchOrder, SearchDirection, MatchCase, MatchByte, SearchFormat)
If Not SearchResult Is Nothing Then
firstMatch = SearchResult.Address
Do
If FindAll Is Nothing Then
Set FindAll = SearchResult
Else
Set FindAll = Union(FindAll, SearchResult)
End If
Set SearchResult = .FindNext(SearchResult)
Loop While Not SearchResult Is Nothing And SearchResult.Address <> firstMatch
End If
End With
End Function
Usage is the same as native .Find, but here is a usage example as requested:
Sub test()
Dim SearchRange As Range, SearchResults As Range, rng As Range
Set SearchRange = MyWorksheet.UsedRange
Set SearchResults = FindAll(SearchRange, "Search this")
If SearchResults Is Nothing Then
'No match found
Else
For Each rng In SearchResults
'Loop for each match
Next
End If
End Sub
Function GetSearchArray(strSearch)
Dim strResults As String
Dim SHT As Worksheet
Dim rFND As Range
Dim sFirstAddress
For Each SHT In ThisWorkbook.Worksheets
Set rFND = Nothing
With SHT.UsedRange
Set rFND = .Cells.Find(What:=strSearch, LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlRows, SearchDirection:=xlNext, MatchCase:=False)
If Not rFND Is Nothing Then
sFirstAddress = rFND.Address
Do
If strResults = vbNullString Then
strResults = "Worksheet(" & SHT.Index & ").Range(" & Chr(34) & rFND.Address & Chr(34) & ")"
Else
strResults = strResults & "|" & "Worksheet(" & SHT.Index & ").Range(" & Chr(34) & rFND.Address & Chr(34) & ")"
End If
Set rFND = .FindNext(rFND)
Loop While Not rFND Is Nothing And rFND.Address <> sFirstAddress
End If
End With
Next
If strResults = vbNullString Then
GetSearchArray = Null
ElseIf InStr(1, strResults, "|", 1) = 0 Then
GetSearchArray = Array(strResults)
Else
GetSearchArray = Split(strResults, "|")
End If
End Function
Sub test2()
For Each X In GetSearchArray("1")
Debug.Print X
Next
End Sub
Careful when doing a Find Loop that you don't get yourself into an infinite loop... Reference the first found cell address and compare after each "FindNext" statement to make sure it hasn't returned back to the first initially found cell.
You may use the Range.Find method:
http://msdn.microsoft.com/en-us/library/office/ff839746.aspx
This will get you the first cell which contains the search string. By repeating this with setting the "After" argument to the next cell you will get all other occurrences until you are back at the first occurrence.
This will likely be much faster.
Based on the idea of B Hart's answer, here's my version of a function that searches for a value in a range, and returns all found ranges (cells):
Function FindAll(ByVal rng As Range, ByVal searchTxt As String) As Range
Dim foundCell As Range
Dim firstAddress
Dim rResult As Range
With rng
Set foundCell = .Find(What:=searchTxt, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not foundCell Is Nothing Then
firstAddress = foundCell.Address
Do
If rResult Is Nothing Then
Set rResult = foundCell
Else
Set rResult = Union(rResult, foundCell)
End If
Set foundCell = .FindNext(foundCell)
Loop While Not foundCell Is Nothing And foundCell.Address <> firstAddress
End If
End With
Set FindAll = rResult
End Function
To search for a value in the whole workbook:
Dim wSh As Worksheet
Dim foundCells As Range
For Each wSh In ThisWorkbook.Worksheets
Set foundCells = FindAll(wSh.UsedRange, "YourSearchString")
If Not foundCells Is Nothing Then
Debug.Print ("Results in sheet '" & wSh.Name & "':")
Dim cell As Range
For Each cell In foundCells
Debug.Print ("The value has been found in cell: " & cell.Address)
Next
End If
Next
You can read the data into an array. From there you can do the match in memory, instead of reading one cell at a time.
Pass cell contents into VBA Array
Below code avoids creating infinite loop. Assume XYZ is the string which we are looking for in the workbook.
Private Sub CommandButton1_Click()
Dim Sh As Worksheet, myCounter
Dim Loc As Range
For Each Sh In ThisWorkbook.Worksheets
With Sh.UsedRange
Set Loc = .Cells.Find(What:="XYZ")
If Not Loc Is Nothing Then
MsgBox ("Value is found in " & Sh.Name)
myCounter = 1
Set Loc = .FindNext(Loc)
End If
End With
Next
If myCounter = 0 Then
MsgBox ("Value not present in this worrkbook")
End If
End Sub
I have the following code I use to go through a sheet and parse the information onto separate sheets based on the string [Start].
Private Sub CommandButton7_Click()
Application.ScreenUpdating = False
Dim i As Long, rFind As Range, rFind1 As Range, rFind2 As Range, rFind3 As Range, rFind4 As Range, ws As Worksheet, s As String, s1 As String, s2 As String
s = "[Start]"
With Sheets("Full History File").Columns(1)
Set rFind3 = .Find(What:="[HistoryEnd]", LookAt:=xlPart, MatchCase:=False, SearchFormat:=False)
Set rFind = .Cells(Rows.Count, 1)
For i = 1 To WorksheetFunction.CountIf(.Cells, "*" & s & "*")
Set rFind = .Find(What:=s, After:=rFind, LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)
If Not rFind Is Nothing Then
Set rFind1 = .Find(What:=s, After:=rFind)
Set ws = Worksheets.Add(After:=Sheets(Sheets.Count))
ws.Name = "Blasted " & i
If i = WorksheetFunction.CountIf(.Cells, "*" & s & "*") Then
Set rFind1 = rFind2.Offset(1)
End If
Range(rFind, rFind1.Offset(-1)).Copy ws.Range("A1")
End If
Next i
End With
Sheets("Blast Summary Sheet").Select
SheetNames
CommandButton6.Visible = True
Application.ScreenUpdating = True
End Sub
My problem is that the information I am working through has changed and I need to adapt the code to do the following:
Search for the string [TrainingModeChanged]
If not found search for the string [TrainingMode]
If not found search for the string [Start]
Once any of the strings are found create the new sheet Blasted with the number and copy the information between the found string up until the next found string which could be either one of the 3 above.
All help in modify the code to do this would be helpfull thanks
I am not entirely sure what you are after, but you could write a function that returns your required string instead of hardcoding it. Function below:
Option Explicit
Function getString() As String
'we will use On Error Resume Next to by pass the expected error if cannot find the string
On Error Resume Next
Dim searchRng As Range
Dim mySheet As Worksheet
Set mySheet = ThisWorkbook.Sheets("Full History File")
'search for first range
Set searchRng = mySheet.Columns(1).Find(What:="[TrainingModeChanged]", LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
'this means search range was found
getString = searchRng.Value
'reset error handling
On Error GoTo 0
Exit Function
End If
'implicit to say if program runs here first search was unsuccessful
Set searchRng = mySheet.Columns(1).Find(What:="[TrainingMode]", LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
'this means search range was found
getString = searchRng.Value
On Error GoTo 0
Exit Function
End If
'implicit to say if program runs here second search was unsuccessful
Set searchRng = mySheet.Columns(1).Find(What:="[Start]", LookIn:=xlValues, LookAt:=xlWhole)
If Not searchRng Is Nothing Then
'this means search range was found
getString = searchRng.Value
On Error GoTo 0
Exit Function
End If
End Function
And you call in your routine as:
s = getString()
And then continue on with your code..
When I press F8 to step through the code line by line, it works perfect. However when I use F5 to run the the whole sub, VBA just runs one For-Next Loop. I am wondering if anyone is having the same issue?
Sub InputPurchaseData()
Dim rngPurchaseInfoLoop As Range, rngPurchaseInfo As Range
Dim rngPurchaseItemsFieldLoop As Range, rngPurchaseItemsField As Range
Dim rngPurchaseItemsLoop As Range, rngPurchaseItems As Range
Dim rngPurchaseDataFieldLoop As Range, rngPurchaseDataField As Range
Dim rngPurchaseDataRowLoop As Range, rngPurchaseDataRow As Range
Dim lngPurchaseItemRow As Long, lngPurchaseDataRow As Long
Dim msgOption As Boolean
Dim strPurchaseNumber As String
wsPurchaseOrder.Activate
Set rngPurchaseInfo = wsPurchaseOrder.Range("A1").CurrentRegion
Set rngPurchaseItemsField = wsPurchaseOrder.Range("B1", Range("B1048576").End(xlUp)).Find(What:="ITEM", _
MatchCase:=True, LookAt:=xlWhole)
Set rngPurchaseItems = Range(rngPurchaseItemsField.Offset(2, 0), Range("B1048576").End(xlUp).Offset(-1, 0))
Set rngPurchaseItemsField = Range(rngPurchaseItemsField, rngPurchaseItemsField.End(xlToRight))
Set rngPurchaseDataField = wsPurchaseData.Range("A1").CurrentRegion.Resize(1)
Set rngPurchaseDataRow = wsPurchaseData.Range("A1").CurrentRegion.Resize(, 1)
For Each rngPurchaseItemsLoop In rngPurchaseItems
If IsNumeric(rngPurchaseItemsLoop.Value) Then
lngPurchaseItemRow = rngPurchaseItemsLoop.Row - rngPurchaseItems.Resize(1).Row + 2
For Each rngPurchaseInfoLoop In rngPurchaseInfo
Set rngPurchaseDataFieldLoop = rngPurchaseDataField.Find(What:=rngPurchaseInfoLoop.Value, MatchCase:=True, LookAt:=xlWhole)
If Not rngPurchaseDataFieldLoop Is Nothing Then _
rngPurchaseDataFieldLoop.Offset(rngPurchaseDataRow.Rows.Count).Value = rngPurchaseInfoLoop.Offset(, 1).Value
Next rngPurchaseInfoLoop
For Each rngPurchaseItemsFieldLoop In rngPurchaseItemsField
Set rngPurchaseDataFieldLoop = rngPurchaseDataField.Find(What:=rngPurchaseItemsFieldLoop.Value, MatchCase:=True, LookAt:=xlWhole)
If Not rngPurchaseDataFieldLoop Is Nothing Then _
rngPurchaseDataFieldLoop.Offset(rngPurchaseDataRow.Rows.Count).Value = rngPurchaseItemsFieldLoop.Offset(lngPurchaseItemRow).Value
Next rngPurchaseItemsFieldLoop
End If
Next rngPurchaseItemsLoop
End Sub
The code below gives either Mismatch or Range error in Excel 2008. How do I fix it?
Sub PEC()
Dim PEC As String, result As Integer
PEC = Range("AE2:AE26848").Value
If PEC = "A.06" Then result = 1
Range("AO2:AO26848").Value = result
End Sub
Sub PEC()
For x = 2 to 26848
If Range("AE" & x) = "A.06" Then Range("AO" & x) = 1
Next x
End Sub
I recommend using the following code. It might seem more complicated, but it certainly does a better and more robust job. It is simply assigning your input and output ranges as SrcRng and DstRng. FIND method for ranges is a good way to check for specific values.
Sub PEC()
Dim SrcRng As Range
Dim DstRng As Range
Dim rcell As Range
Set SrcRng = Range ("AE2:AE26848")
Set DstRng = Range("AO2:AO26848")
Set rcell = SrcRng.Find(what:="A.06", after:=SrcRng.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, MatchCase:=False)
If Not rcell Is Nothing Then
DstRng.Value = 1
End If
End Sub
Dim Counter As Integer
Dim Maxhouse As Integer
Dim FindHouse As Range
Dim RangeVar As Range
Dim HousesRange As Range
For Counter = 1 To MaxHouse
ActiveSheet.Cells(16, 2 + Counter).Select
House = ActiveCell
With Sheets("Sheet1").Range("C:KP")
Set FindHouse = Cells.Find(What:=House, _
After:=Cells(17, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not FindHouse Is Nothing Then
If Counter = 1 Then
Set HousesRange = FindHouse
Else
Set RangeVar = FindHouse
Set HousesRange = Union(HousesRange, RangeVar)
End If
End If
End With
Next Counter
For Each RCell In HousesRange.Cells
Application.Goto RCell, True
Next RCell**
Now my problem is with the for loop which traverses through the named range 'HousesRange'
So lets say that HousesRange contains [2,5,9,10].
Here HousesRange is a subset of the row [1,2,3,4,5,6,7,8,9,10] in my Sheet
And lets assume that HousesRange was established through the order of [9,10,5,2] (through the 1st for loop with the union).
Now as I traverse through HousesRange with just rCells (the second for loop), it takes me to 9, 10, 5 then 2.
But I want it to take me to 2, 5, 9 then 10
Can some body shed some light to this?
I had always thought that named ranges are ALWAYS traversed through left to right and then top to bottom.
Thank you so much in advance
Ok this is the long way round, but it should work:
Instead of using Union build your list of found houses in a dictionary object.
Then sort the ranges using Bubblesort HouseRangeDic
You should finally be able to use it in the right order:
Dim Counter As Integer
Dim Maxhouse As Integer
Dim FindHouse As Range
Dim RangeVar As Range
Dim HousesRange As Range
'****** NEW **********
Dim foundHouseCount
foundHouseCount = 1
Dim HouseRangeDic
Set HouseRangeDic = CreateObject("Scripting.dictionary")
'*********************
For Counter = 1 To Maxhouse
ActiveSheet.Cells(16, 2 + Counter).Select
House = ActiveCell
With Sheets("Sheet1").Range("C:KP")
Set FindHouse = Cells.Find(What:=House, _
After:=Cells(17, 1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not FindHouse Is Nothing Then
HouseRangeDic.Add foundHouseCount, RangeVar '**** NEW ***
foundHouseCount = foundHouseCount + 1 '**** NEW ***
End If
End With
Next Counter
'**** NEW ***
Bubblesort HouseRangeDic
For i = 1 To HouseRangeDic.Count
Application.Goto HouseRangeDic(i), True
Next
'************
Sub Bubblesort(ByRef rangeDic)
Dim tempRange
For i = 1 To rangeDic.Count - 1
For j = i To rangeDic.Count
If rangeDic(i).Address > rangeDic(j).Address Then
Set tempRange = rangeDic(i)
Set rangeDic(i) = rangeDic(j)
Set rangeDic(j) = tempRange
End If
Next
Next
End Sub
See if this works for you. Notice my "After:=" is set to the LAST cell of the range, so the first find starts at the beginning of the range.
Sub loopCells()
Dim FindHouse As Range
Dim HousesRange As Range
Dim rcell As Range
Dim r As Range
Dim sAdd As String
Dim House As Long
Set r = Sheets("Sheet1").Range("$C$15:$K$20") 'change to suit
House = 11'change to suit
With r
Set FindHouse = .Find(What:=House, After:=r(.Cells.Count), LookIn:=xlValues, LookAt:=xlWhole, _
SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
If Not FindHouse Is Nothing Then
sAdd = FindHouse.Address
Do
If HousesRange Is Nothing Then
Set HousesRange = FindHouse
Else
Set HousesRange = Union(HousesRange, FindHouse)
End If
Set FindHouse = .FindNext(FindHouse)
Loop While Not FindHouse Is Nothing And FindHouse.Address <> sAdd
End If
End With
For Each rcell In HousesRange
Application.Goto rcell
Next rcell
End Sub