I'm trying to find a specific value in a specific column. For example the value 100000 in the column B. The following code only works if the column is wide enough to display the full number:
Dim rngSearchRange As Range
Set rngSearchRange = ThisWorkbook.Worksheets(1).Columns(2)
Dim searchTerm As Variant
searchTerm = 100000
Dim rngResultRange As Range
Set rngResultRange = rngSearchRange.Find(What:=searchTerm, lookin:=xlValues, lookat:=xlWhole)
As soon as the column gets to narrow, so Excel only displays ##### instead of 100000 in the specific cell the find-method returns Nothing.
Is there a way to use the find-method based on the actual values and not on the display of the values? If not, are there any alternatives to For Each cell In rng.Cells? Eventually, I'm looing the method which usees up the least resources.
Note: the searchRange is only one column, the searchValue either doesn't exist or only exists once.
Note: there is a followup question on using match()
Note: from time to time it seems to work although neither data nor code changes. Unfortunately, I can not reproduce the change. This whole thing might be a bug indeed
Can reproduce the Find failing if the column width is too narrow.
Match doesn't have this problem.
Sub dural()
Dim rngSearchRange As Range
Set rngSearchRange = ThisWorkbook.Worksheets(1).Columns(2)
Dim searchTerm As Variant
searchTerm = 100000
Dim rngResultRange As Range
Dim found As Variant
found = Application.Match(searchTerm, rngSearchRange, 0)
If Not IsError(found) Then
Set rngResultRange = rngSearchRange.Cells(found)
MsgBox rngResultRange.Address
End If
End Sub
Depending on your use case, this may be an option, or if not, maybe Range.AutoFit? Though with "I'm trying to find a specific value in a specific column," it sounds like this could be an option.
You could either get the range into an array and loop the array, or just use MATCH:
Sub test()
Dim rngSearchRange, rngResultRange As Range
Dim searchTerm As Variant
Dim vRow As Variant
Set rngSearchRange = ThisWorkbook.Worksheets(1).Columns(2)
searchTerm = 10000
vRow = Application.Match(searchTerm, rngSearchRange, 0)
If Not IsError(vRow) Then
Set rngResultRange = rngSearchRange.Resize(1, 1).Offset(vRow - 1, 0)
Else
MsgBox "Not Found"
End If
End Sub
Try this:
Sub test()
Dim rngSearchRange, rngResultRange As Range
Dim searchTerm As Variant
Set rngSearchRange = ThisWorkbook.Worksheets(1).Columns(2)
searchTerm = 10000
Set rngResultRange = rngSearchRange.Find(what:=searchTerm, LookIn:=xlValues)
End Sub
The issue with find is that it only looks for displayed values for some reason, identical to the behaviour of the search box you get pressing crtl+F or clicking the "Find & Select" option on your "Home" ribbon. There is currently no known way to fix this (looking in xlValues and the like as the comments pointed out)
As there are various ways to get around this, the (slowest) but most reliable one would be to use a foreach loop as so:
For Each cel In rngSearchRange
If cel.Value = searchTerm Then
Set rngResultRange = cel
exit for '<-If you want the first result, leave this. If you want the last result, omit. Using the first result could be significantly quicker as it will stop looping right away.
End If
Next cel
Just make sure you set your range as definite value like Range("A1:B87") instead of Columns(2) as this will throw a type mismatch error. If you want to search column B, use Range("B:B") instead.
This is a cheating-version: It will copy the range to a temporary Worksheet, converting Formulas to Values, and do the lookup there.
Public Function FindValueInRange(ByVal RangeToSearch As Range, ByVal ValueToFind As Variant) As Range
Dim WasActive As Worksheet, ScreenUpdating As Boolean, Calculation As XlCalculation
'Store current position
Set WasActive = ActiveSheet
ScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
Calculation = Application.Calculation
Application.Calculation = xlCalculationManual
'Let's get to work!
Set FindValueInRange = Nothing 'Default to Nothing
On Error GoTo FunctionError
Dim TempSheet As Worksheet, FoundCell As Range, DisplayAlerts As Boolean
'Create Temp Sheet
Set TempSheet = Worksheets.Add
'Copy data to Temp Sheet, in the same location
TempSheet.Range(RangeToSearch.Address(True, True, xlA1, False)).Value = RangeToSearch.Value
'Column Width to Maximum!
TempSheet.Range(RangeToSearch.Address(True, True, xlA1, False)).EntireColumn.ColumnWidth = 255
'Search the cells in the Temp Sheet
Set FoundCell = TempSheet.Range(RangeToSearch.Address(True, True, xlA1, False)).Find(ValueToFind, LookIn:=xlFormulas, LookAt:=xlWhole)
'Return the found cell, but on the original Worksheet
If Not (FoundCell Is Nothing) Then Set FindValueInRange = RangeToSearch.Worksheet.Range(FoundCell.Address(True, True, xlA1, False))
'Remove the Temp Sheet
DisplayAlerts = Application.DisplayAlerts
Application.DisplayAlerts = False
TempSheet.Delete
Application.DisplayAlerts = DisplayAlerts
Set TempSheet = Nothing
FunctionError:
On Error GoTo -1 'Reset the error buffer
'Restore previous position
WasActive.Activate
Application.Calculation = Calculation
Application.ScreenUpdating = ScreenUpdating
End Function
This would then be used like so:
Set rngResultRange = FindValueInRange(rngSearchRange, searchTerm)
Related
I have googled and struggled with this for hours now.
I have a Control workbook, that pulls data from a varied amount of other workbooks (the Control workbook also creates the other workbooks and saves the names and dir of said workbooks so that they can be called later)
This piece of code is the problem.
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Declare_Sheets
Dim SearchresultROW
Dim Searchresult As String
Dim complexrow As Integer
Dim CurrSheet As Worksheet
Dim Stype As String
Dim startROW As Integer
Dim endROW As Integer, SearchCOL As Integer, OffROW As Integer
Dim PDATArange As Range, CDATArange As Range
Dim Dateyear, Datemonth, datetest As String
Stype = WSRD.Range("B11")
'Find complex to work with
complexrow = WSSS.Range("F7")
WSSS.Activate
SearchresultROW = Range(Cells(7, 15), Cells(complexrow, 15).Find(Callsheet).Address).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
The below code is the problem extract
complexrow = WSSS.Range("F7")
WSSS.Activate
SearchresultROW = Range(Cells(7, 15), Cells(complexrow, 15).Find(Callsheet).Address).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
1st problem
I cant get the find() to work without activating worksheet - WSSS
Declare_Sheets gets run at the start which declares WSSS, this works everywhere else in my code, but not with this find().
2nd problem
The code below compiles and finishes, BUT - It does not return the correct data.
This code calls starts the macro
Cancel = True
Dim Calsheet As String
If Target.Column <> 1 Then Exit Sub
Calsheet = Target.Value
Call Call_Readings(Calsheet)
End Sub
There are currently 2 possibilities
I double click on Casper Tcomp 4.
Callsheet = "Casper Tcomp 4" - Which is correct (target of the double click)
Complexrow = "9" - Which is correct (this will increment as new sheets are added)
SearchresultROW = "7" - This is wrong, it should be 8
I have tried adding LookAt:=xlWhole and LookIn:-xlValues, doesnt change a thing
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Declare_Sheets
Dim SearchresultROW
Dim Searchresult As String
Dim complexrow As Integer
Dim CurrSheet As Worksheet
Dim Stype As String
Dim FindResult As Range
Dim startROW As Integer
Dim endROW As Integer, SearchCOL As Integer, OffROW As Integer
Dim PDATArange As Range, CDATArange As Range
Dim Dateyear, Datemonth, datetest As String
Stype = WSRD.Range("B11")
'Find complex to work with
complexrow = WSSS.Range("F7")
On Error Resume Next 'next line will error if nothing is found
Set FindResult = WSSS.Range(WSSS.Cells(7, 15), WSSS.Cells(complexrow, 15)).Find(What:=Callsheet, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=False)
On Error GoTo 0 'always re-activate error reporting!
If Not FindResult Is Nothing Then 'check if find was successful
SearchresultROW = FindResult.Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Else 'if nothing was found show message
MsgBox "NO WB FOUND.", vbCritical
End If
This solved the problem, thanks for the assistance Pᴇʜ
Your code without .Activate would look something like below. Note that every Range, Cells, Rows or Columns object needs to be referenced with the correct Workbook/Worksheet:
complexrow = WSSS.Range("F7")
'try to find something
Dim FindResult As Range
On Error Resume Next 'next line will error if nothing is found
Set FindResult = WSSS.Cells(complexrow, 15).Find(What:=Callsheet, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, MatchByte:=False)
On Error GoTo 0 'always re-activate error reporting!
If Not FindResult Is Nothing Then 'check if find was successful
SearchresultROW = WSSS.Range(WSSS.Cells(7, 15), FindResult).Row
Searchresult = WSSS.Cells(SearchresultROW, 15).Offset(0, 1)
Else 'if nothing was found show message
MsgBox "nothing found.", vbCritical
End If
Note that if using the Range.Find method you need to check if something was found before you can use the result of Find. Otherwise it will throw an error. Also note that the documentation of Find says that …
The settings for LookIn, LookAt, SearchOrder, and MatchByte are saved each time you use this method.
So if you don't define them each time using Find it will use whatever was used last by either VBA or the user interface. Since you have no control about what was used last by the user interface I highly recomment to define them everytime using Find or you will get random results.
Also note that Callsheet is not defined in your code yet, so check that.
you all were a great help with my last issue, so I figured Id ask another question. I am currently creating a code that keeps track of a mailroom's inventory. The code that I am working on is a textbox that whenever something is typed, it copies the value to the excel and it triggers an advanced search. I want to use xlfiltercopy to prevent visual damage to the excel sheet and so it is easier to update the listbox in the userform with the filtered information. Please let me know if you can find a reason that the error "AdvancedFilter method of Range class failed"
EDIT: If possible, I would like to email the entire excel to someone to see if the program works on another computer. I cannot physically think of a way to get it to work. Please consider it!
' Input on the 2nd page
' This code will update the list box below automatically as you type a name
Private Sub TextBox5_Change()
If Me.TextBox5.Value = "" Then
Exit Sub
End If
Dim wks As Worksheet
Set wks = ThisWorkbook.Sheets("Mail_Inventory")
Dim rgData As Range
Dim rgCriteria As Range
Dim rgOutput As Range
Dim currentinventory As Long
Dim filteredcurrent As Long
Dim temp As Long
temp = wks.Range("AS1").Value
If temp > 0 Then
wks.ListObjects("CurrentFiltered").DataBodyRange.Rows.Delete
End If
wks.Range("AP6").Value = Me.TextBox5.Value
currentinventory = wks.Range("A1").Value
'Set rgData = ThisWorkbook.Worksheets("Mail_Inventory").Range("A2:H" & currentinventory + 2)
'Set rgCriteria = ThisWorkbook.Worksheets("Mail_Inventory").Range("AP5:AP6")
'Set rgOutput = ThisWorkbook.Worksheets("Mail_Inventory").Range("AS2:AZ2")
Set rgData = Range("A2:H" & currentinventory + 2)
Set rgCriteria = Range("AP5:AP6")
Set rgOutput = Range("AS2:AZ2")
rgData.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=rgCriteria, CopytoRange:=rgOutput
'wks.Range("A2:H" & currentinventory + 2).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wks.Range("AP5:AP6"), CopyToRange:=wks.Range("AS2:AZ2")
'filteredcurrent = wks.Range("AS1").Value
'Me.ListBox2.Clear
'Me.ListBox2.RowSource = wks.Range("AS2:AV" & filteredcurrent + 2)
Can someone tell me the correct syntax for this code I am trying to execute? From a 1D range of string values, I want to pick a certain string say "this" and calculate the sum of all the values of "this" which are displayed in the immediate next column. It's been eating my head up for hours. And also, is there another better way to do it?
With Application.WorksheetFunction
Range("AA2").Value = .Sum(.Index(ws(1).Range("F8"), .Match(ws(1).Range("AA1"), ws(1).Range("E8:E16"), 0), 0) **:** .index(ws(1).Range("F16"), .Match(ws(1).Range("AA1"), ws(1).Range("E8:E16"), 0), 0)
End With
In excel it would be:
=SUMIF(E8:E16,"=this",F8:F16)
So in your macro try:
Option Explicit
Public Sub StackOverflowDemo()
Dim conditionText As String
Dim ws As Worksheet
Dim target As Range
Dim sourceCriteria As Range
Dim sourceSum As Range
Set ws = ThisWorkbook.Sheets(1)
conditionText = "this"
Set target = ws.Range("AA2")
Set sourceCriteria = ws.Range("E8:E16")
'the above stuff would probably be passed as parameters since I doubt you want that stuff hard coded
'from here on there's no hard coding.
Set sourceSum = sourceCriteria.Offset(0, 1)
target.Value = WorksheetFunction.SumIf(sourceCriteria, "=" & conditionText, sourceSum)
End Sub
Update: Refactored to show the reusability / benefit of using variables:
Option Explicit
Public Sub StackOverflowDemo()
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets(1)
DoSumIf ws.Range("E8:E16"), "this", ws.Range("AA2")
DoSumIf ws.Range("E8:E16"), "that", ws.Range("AA3")
DoSumIf ws.Range("B2:B32"), "who", ws.Range("AA4")
End Sub
Private Sub DoSumIf(sourceCriteria As Range, conditionText As String, target As Range)
Dim sourceSum As Range
Set sourceSum = sourceCriteria.Offset(0, 1)
target.Value = WorksheetFunction.SumIf(sourceCriteria, "=" & conditionText, sourceSum)
End Sub
You can do it in VBA using something to this effect:
This will search E2:E300 for the string "P09" and sum the column directly to the right.
Sub Test123455()
Dim MyRange As Range
Set MyRange = Nothing
Dim curcell As Range
For Each curcell In Range("E2:E300")
If InStr(1, curcell.Value, "P09", vbTextCompare) > 0 Then
If MyRange Is Nothing Then
Set MyRange = curcell
Else
Set MyRange = Union(MyRange, curcell.Offset(0, 1))
End If
End If
Next curcell
MsgBox Application.WorksheetFunction.Sum(MyRange)
End Sub
I have recorded an Excel function (Iferror/Vlookup) which I need to modify to inpput variables to make it more dynamic (Allow for columns moving). Below is a brief outline of what I want to do. The First section is the recorded Function and the variables I want to add. The second section is my proposed solution. My problem is I need to drop the function into excel and copy it down over 50,000 rows. So my error handling solution won't work here. Is it possilbe to make the original recorded function dynamic using iferror/Vlookup. Any help appreciated.
Dim Lookup1 As Long
Dim LookupOffset As Long
Dim LRange As Range
Lookup1 = -99
LookupOffset = 28
Set LRange = Column("CU:CV")
With Worksheets("consolidated")
.Cells(2, 99).FormulaR1C1 = _
"=RC[-71]-IFERROR(VLOOKUP(RC[-12],C[-2]:C[-1],2,FALSE),0)"
.Cells(2, 99).Copy Range(.Cells(2, 99), .Cells(glLastRow, 99))
Application.CutCopyMode = False
.Calculate
End With
''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Proposed Solution
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Res As Variant
On Error Resume Next
Err.Clear
Res = Application.WorksheetFunction.VLookup(Lookup1 - LookupOffset, LRange, 2, False)
If Err.Number = 0 Then
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Value found by VLookup. Continue normal execution.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
Else
''''''''''''''''''''''''''''''''''''''''''''''''''''
' Value NOT found by VLookup. Error handling code here.
'''''''''''''''''''''''''''''''''''''''''''''''''''''
End If
Try this one:
Sub LookUpMod()
Dim wSht As Worksheet: Set wSht = ThisWorkbook.Sheets("Consolidated")
With wSht
On Error Resume Next
.Cells(2, 99).Formula = "=XCV34-IFERROR(VLOOKUP(XFC34,$I:$J,2,FALSE),0)"
.Range(Cells(2, 99), Cells(glLastRow, 99)).FillDown
.Calculate
On Error GoTo 0
End With
End Sub
Just noticed, though, that you don't have glLastRow instantiated properly. Let us know if this helps.
EDIT:
As per chat with OP:
Function LookUpMod(Str As Variant, Rng As Range, OffsetToRight As Long)
Application.Volatile
LookUpMod = Rng.Cells.Find(What:=Str).Offset(0, OffsetToRight).Value
End Function
A simple flexible lookup is what is needed.
I'm currently trying to trace the dependencies of a complex set of Excel spreadsheets. My ideal end goal would be a tree structure, starting with my first spreadsheet. However, I don't want to include all of the dependencies of the child spreadsheets, just the ones of the cells referenced by the original spreadsheet. For example:
In cell A1 of my first workbook:
somebook.xls!Sheet1!C2
I want to look at cell C2 in sheet 1 of somebook.xls for its (external) dependencies, and then recurse.
At the moment I'm using LinkInfo to get a list of external dependencies, searching using Find, and I'm struggling with vbscript's primitive regex capabilities to try and extract the address out of the cells I find. This is not a brilliant way of doing things.
Does anyone know if Excel will tell you which cells in an external spreadsheet are being referenced? If not, any other tools that might help?
Thanks.
This answer is based off Bill Manville's macro from many years back. The macro still works, but I broke it out into functions allowing for more flexibility and reusability. The main addition by me is the ability to find external dependencies only, and the extension to both precedents and dependents. I also added a call to a custom macro called unhideAll; this was necessary for me as dependencies were not being found in hidden worksheets.
'Module for examining depedencies to/from a sheet from/to other sheets
Option Explicit
Sub showExternalDependents()
Dim deps As Collection
Set deps = findExternalDependents(ActiveCell)
Call showDents(deps, True, "External Dependents: ")
End Sub
Sub showExternalPrecedents()
Dim precs As Collection
Set precs = findExternalPrecedents(ActiveCell)
Call showDents(precs, True, "External Precedents: ")
End Sub
'external determines whether or not to print out the absolute address including workbook & worksheet
Sub showDents(dents As Collection, external As Boolean, header As String)
Dim dent As Variant
Dim stMsg As String
stMsg = ""
For Each dent In dents
stMsg = stMsg & vbNewLine & dent.Address(external:=external)
Next dent
MsgBox header & stMsg
End Sub
Function findPrecedents(rng As Range) As Collection
Set findPrecedents = findDents(rng, True)
End Function
Function findDependents(rng As Range) As Collection
Set findDependents = findDents(rng, False)
End Function
Function findExternalPrecedents(rng As Range) As Collection
Set findExternalPrecedents = findExternalDents(rng, True)
End Function
Function findExternalDependents(rng As Range) As Collection
Set findExternalDependents = findExternalDents(rng, False)
End Function
'Gives back only the dependencies that are not on the same sheet as rng
Function findExternalDents(rng As Range, precDir As Boolean) As Collection
Dim dents As New Collection
Dim dent As Range
Dim d As Variant
Dim ws As Worksheet
Set ws = rng.Worksheet
For Each d In findDents(rng, precDir)
Set dent = d
With dent
If Not (.Worksheet.Name = ws.Name And .Worksheet.Parent.Name = ws.Parent.Name) Then _
dents.Add Item:=dent
End With
Next d
Set findExternalDents = dents
End Function
'this procedure finds the cells which are the direct precedents/dependents of the active cell
'If precDir is true, then we look for precedents, else we look for dependents
Function findDents(rng As Range, precDir As Boolean) As Collection
'Need to unhide sheets for external dependencies or the navigate arrow won't work
Call mUnhideAll
Dim rLast As Range, iLinkNum As Integer, iArrowNum As Integer
Dim dents As New Collection
Dim bNewArrow As Boolean
'Appliciation.ScreenUpdating = False
If precDir Then
ActiveCell.showPrecedents
Else
ActiveCell.ShowDependents
End If
Set rLast = rng
iArrowNum = 1
iLinkNum = 1
bNewArrow = True
Do
Do
Application.Goto rLast
On Error Resume Next
ActiveCell.NavigateArrow TowardPrecedent:=precDir, ArrowNumber:=iArrowNum, LinkNumber:=iLinkNum
If Err.Number > 0 Then Exit Do
On Error GoTo 0
If rLast.Address(external:=True) = ActiveCell.Address(external:=True) Then Exit Do
bNewArrow = False
dents.Add Item:=Selection
iLinkNum = iLinkNum + 1 ' try another link
Loop
If bNewArrow Then Exit Do
iLinkNum = 1
bNewArrow = True
iArrowNum = iArrowNum + 1 'try another arrow
Loop
rLast.Parent.ClearArrows
Application.Goto rLast
Set findDents = dents
End Function
Sub mUnhideAll()
'
' mUnhideAll Macro
'
' Unhide All
Dim ws As Worksheet
For Each ws In Worksheets
ws.Visible = True
Next
'Sheets("Sprint Schedule Worksheet").Visible = False
End Sub
Excel's built in support, as you're finding, is limited and can be extremely frustrating.
In my experience, I've found a couple of tools from http://www.aivosto.com/ to be useful; Visustin v6 is especially useful for code related auditting/processing.
Here's a simpler version of Colm Bhandal's findDents and findExternalDents. It assumes all worksheets were made visible and arrows were cleared before use.
Function findDents(rCell As Range, bPrec As Boolean) As Collection
'Return all direct precedents (bPrec=True) or dependents (bPrec=False) of rCell
Dim sAddr As String, nLink As Integer, nArrow As Integer
Const bAbs As Boolean = False, bExt As Boolean = True
Set findDents = New Collection
If bPrec Then
rCell.showPrecedents ' even if rCell has no formula
Else
rCell.showDependents
End If
On Error Resume Next ' ignore errors
sAddr = rCell.Address(bAbs, bAbs, xlA1, bExt)
nArrow = 1
Do
nLink = 1
Do
rCell.NavigateArrow bPrec, nArrow, nLink
If ActiveCell.Address(bAbs, bAbs, xlA1, bExt) = sAddr Then Exit Do
findDents.Add Selection ' possibly more than one cell
nLink = nLink + 1
Loop
If nLink = 1 Then Exit Do
nArrow = nArrow + 1
Loop
On Error GoTo 0
If bPrec Then
rCell.showPrecedents Remove:=True
Else
rCell.showDependents Remove:=True
End If
End Function
Function findExternalDents(rCell As Range, bPrec As Boolean) As Collection
'Return ...Dents that are NOT in the same workbook and worksheet as rCell
Dim rDent As Range, wsName As String, wbName As String
With rCell.Worksheet: wsName = .Name: wbName = .Parent.Name: End With
Set findExternalDents = New Collection
For Each rDent In findDents(rCell, bPrec)
If rDent.Worksheet.Name <> wsName Or rDent.Worksheet.Parent.Name <> wbName Then findExternalDents.Add Item:=rDent
Next rDent
End Function
You might want to modify this to use a SortedList instead of a Collection. In that case, change
findDents.Add Selection
to
findDents.Add Selection.Address(bAbs, bAbs, xlA1, bExt), Null