I have over 200 worksheets in a given workbook and am trying to get some prices based on given dates. I am trying to use the Find method to search column A in each sheet (apart from the Summary sheet) to find the given date and then offset 4 columns to get the appropriate prices. The code is failing on the fr = r.Offset(0, 4).Value and gives Object variable or With block variable not set error. I have tried tweaking the code and doing some other approaches, but keep getting a similar error.
Sub fill()
ActiveWorkbook.Worksheets("Summary").Activate
Dim From_Date As Variant
Dim To_Date As Variant
From_Date = Range("A2").Value
To_Date = Range("A1").Value
Dim rng As Worksheet
Dim fr As Variant
Dim tr As Variant
Dim pct As Variant
Dim r As Range
For Each rng In ActiveWorkbook.Worksheets
If rng.Name <> "Summary" Then
rng.Activate
Set r = Range("A:A").Find(To_Date)
fr = r.Offset(0, 4).Value
End If
Next rng
End Sub
You need to check the result of the Find() method, as explained here:
Set r = Range("A:A").Find(To_Date)
If Not (r Is Nothing) Then
fr = r.Offset(0, 4).Value
...
End If
(Keep out not to use fr in case r is null, it might still contain the result of the previous loop)
Related
I hope that someone could help me with an index match formula that is made using a loop and storing the results data on the column.
Let's say that my data is following to make it simple:
We have an employee column and a salary column. I want to find all the salary options for HR employees.
I would like to store automatically all the results found on the column J (Researched input is in column I). And I want to finish the loop after not finding any new values.
Here is the data:
My initial code is down below without a loop to go down on the range:
Sub test()
Dim oCell As Range
Dim i As Long
i = 1
Do While Worksheets("Sheet1").Cells(i, 9).Value <> ""
Set oCell = Worksheets("Sheet1").Range("A:A").Find(What:=Worksheets("Sheet1").Cells(i, 9))
If Not oCell Is Nothing Then Worksheets("Sheet1").Cells(i, 10) = oCell.Offset(0, 1)
i = i + 1
Loop
End Sub
The problem stems from two main things:
The .Find range you are searching is the entire column A, which is then set to a .Range object (oCell). However, from my VBA understanding the .Find method cannot apply the cell address of each instance of the string/search parameter you are looking for. It will only apply the cell address of the first one it finds. To set a .Range object of non-contiguous rows you could use UNION function.
The .Find(What:= ... is set to a dynamic range which moves down column I as the loop continues. This means it will never find a match because it is searching the preceding column.
Here is a suggested solution, which hopefully you can adapt to your real world data:
Option Explicit
'
Sub test()
Dim oCell As Range
Dim i As Long
i = 1
Do While Worksheets("Sheet1").Cells(i, 2).Value <> ""
' Included as a sense check when stepping through your code to confirm loop is on correct cell
'Debug.Print Cells(i, 2).Address
'Debug.Print Cells(i, 2).Value
'Debug.Print "NEXT"
Set oCell = Worksheets("Sheet1").Range("A1:A10").Find(What:="HR")
If Not oCell Is Nothing Then Worksheets("Sheet1").Cells(i, 3) = oCell.Offset(0, 1)
i = i + 1
Loop
End Sub
Try this:
Option Explicit
Sub test()
Dim i As Long
Dim wb as Excel.Workbook
Dim ws as Excel.Worksheet
i = 2 ' we don't need the header
set wb = ActiveWorkBook
set ws = wb.Sheets("Sheet1") ' or wb.Sheets(1)
Do While ws.Cells(i, 1) <> ""
If ws.Cells(i,1) = "HR" then
ws.Cells(i, 3) = ws.Cells(i,2)
End If
i = i + 1
Loop
End Sub
Tested and found working
I have two set of range named as LIST_KEY and LIST_CAT. In Column A, user will add some data which will contain one of the one of the text from LIST_KEY. I would like to get corresponding Category list from LIST_CAT depends upon the Key value
I am using below VBA code to achieve this. This include a Array formula.
Sub match()
Dim ss As Workbook
Dim test As Worksheet
Set ss = Excel.Workbooks("test.xlsm")
Set test = ss.Worksheets("Sheet1")
For i = 2 To test.Cells(Rows.Count, "A").End(xlUp).Row
Cells(i, "B").FormulaArray = "=INDEX(LIST_CAT,MATCH(TRUE,ISNUMBER(SEARCH(LIST_KEY,RC[-1])),0))"
Cells(i, "B").Formula = Cells(i, "B").Value
Next i
End Sub
This code works perfect if there is less data to fetch. But in my original use case, I will have around 8000 rows. Due to this large number of columns excel will go to not responding state after 2-3 minutes.
Instead of adding Array formula to column B, Is there anyway to convert that into VBA to run this faster. Sorry, I am new to this VBA stuff and dont have much experience
Try the following code, which uses arrays instead of worksheet formulas...
Option Explicit
Sub GetCategories()
Dim sourceWorkbook As Workbook
Set sourceWorkbook = Workbooks("test.xlsm")
Dim sourceWorksheet As Worksheet
Set sourceWorksheet = sourceWorkbook.Worksheets("Sheet1")
Dim lookupArray As Variant
lookupArray = sourceWorkbook.Names("LIST_KEY").RefersToRange.Value
Dim returnArray As Variant
returnArray = sourceWorkbook.Names("LIST_CAT").RefersToRange.Value
Dim tableArray As Variant
Dim lastRow As Long
With sourceWorksheet
lastRow = .Cells(.Rows.Count, "a").End(xlUp).Row
tableArray = .Range("A2:B" & lastRow).Value
End With
Dim desc As String
Dim i As Long
Dim j As Long
For i = LBound(tableArray, 1) To UBound(tableArray, 1)
desc = tableArray(i, 1)
For j = LBound(lookupArray, 1) To UBound(lookupArray, 1)
If InStr(1, desc, lookupArray(j, 1), vbTextCompare) > 0 Then
tableArray(i, 2) = returnArray(j, 1)
Exit For
End If
Next j
Next i
sourceWorksheet.Range("B2").Resize(UBound(tableArray, 1), 1).Value = Application.Index(tableArray, 0, 2)
End Sub
I have data contained in "Sheet1" with only 2 columns. Column "A" and Column "B".
Below are my questions
The below code which is working fine, but at the moment, I have to put every single word within the cell to bring up a result. Is there a way there, where I can type only a word or a few words contained within that cell that it will bring up a result.
Is there a way, if I have 2 different results pulled from the data, like duplicates, what is the code to see the next. Do I need a command button like eg: Next
Private Sub CommandButton1_Click()
Dim rng As Range
Dim cl As Range
Dim vFind
Dim R As Long
Set rng = Sheet1.Range(Cells(1, 1), Cells(Rows.Count, 1).End(xlUp))
vFind = Me.TextBox1.Text
With rng
Set cl = .Find(vFind, LookIn:=xlValues)
If Not cl Is Nothing Then R = cl.Row
Me.TextBox2.Value = Cells(R, 2).Value
End With
I'm currently writing a program to analyze some data, and my Debugger is throwing the "Duplicate Declaration in Current Scope" error, highlighting "Dim rTickers As Range". I cannot find a duplicate anywhere in here. Is there some other reason I could be getting this error? Thanks for your time.
Sub TSV_Ticker()
'Create Dictionary To get Unique Values From Column A
Dim dTickers As New Dictionary
Dim i As Long
For i = 2 To Rows.Count
On Error Resume Next
dTickers.Add (Cells(i, 1).Value), CStr(Cells(i, 1).Value)
Next
'Create The Ticker And Sum Column Headers
Range("J1").Value = "<Sum>"
Range("I1").Value = "<Ticker>"
'Define where we will be putting our keys
Dim uTickers As Range
Set uTickers = Range("I2")
'Convert Keys into array for syntax reasons
aTickers = dTickers.Keys
'Resize the range so it will fit the array
Set rTickers = rTickers.Resize(UBound(aTickers), 1)
'Put array into range, verticaly
rTickers.Value = Application.Transpose(aTickers)
'Define Range of column A
Dim rTickers As Range
Set rTickers = Range("A2:A" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
Dim TSV As Long
'Defining some Date Variables (Column B)
Dim fDate As Integer
Dim eDate As Integer
Dim rDates As Range
Set rDates = Range("B2:B" & ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row)
'And The Open / Close Variables (Colums C&F)
Dim vOpen As Double
Dim Vclose As Double
Dim Delta As Double
Dim pDelta As Double
'Adding Some Columns
sht.Range("J1").EntireColumn.Insert
Range("J1").Value = "Yearly Change"
sht.Range("K1").EntireColumn.Insert
Range("K1").Value = "Percent Change"
For Each Cell In rTickers
'Searching our range that we put the Array in for matching Values
Set t = rTickers.Find(Cell.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not t Is Empty Then
'add column G's value to corresponding I value
Cells(t.Row, 10).Value = Cells(t.Row, 10).Value + Cells(Cell.Row, 7).Value
End If
Next Cell
End Sub
As commented, without using Option Explicit variables are created at the first instance.
So in your code, rTickers is already created when this below line is executed:
Set rTickers = rTickers.Resize(UBound(aTickers), 1)
That being said, below line will give you a compile error:
Dim rTickers As Range
because rTickers variable has already been created.
I'll post this as answer for others reference.
But if Rory or Ashlee wish to add their answers, I'll delete mine :).
This is my first time asking for help on any VBA programming sites. I am very new to VBA programming (had some experience 10 years ago) and am trying to create a document cross reference tool for work in which the user can easily search for a document number and see where that document number is referenced in other documents. I am using Excel 2010.
Over the past 3 days scouring websites, and reading Excel VBA programming for dummies (me) a coworker loaned to me, this is the code I have currently written, which successfully comes up with the desired inquiry box, but I can not seem to get the search inquiry to work, or the copy paste commands to work.
I am trying my utmost to be respectful of this site's rules, and demonstrate my efforts at trying to write this code without simply getting someone else to do all the work, but I obviously need help:
Private Sub CommandButton1_Click()
Dim rngCell As Range
Dim ws As Worksheet
Dim lngLstRow As Long
Dim lngLstCol As Long
Dim strSearch As String
Dim r As Long
Dim x As Variant
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
Sheets("DMR").Select
'Loop through sheet DMR and search for "search value". The search value may be in several rows, but will only appear once in a row.
For r = 1 To endRow
x = Range("G3:EP7002").Value 'yes-there are 7002 rows of data all starting at column G and potentially ending at column EP. There are many blank cells.
If Cells(r, x).Value = "Search Value" Then
'Copy the cells at column A and D of found search value row in Sheet "DMR"
Range(Cells(r, "A"), Cells(r, "D")).Select
Selection.Copy
'Switch to sheet "SEARCH" & paste two cells from sheet "DMR" into sheet "SEARCH" cells A5:B5
Sheets("SEARCH").Select
Range(r, "A5:B5").Select
ActiveSheet.Paste
'Next time you find a match in sheet "DMR", it will be pasted in the next row on sheet "SEARCH"
pasteRowIndex = pasteRowIndex + 1
'Switch back to sheet DMR & continue to search for your criteria
Sheets("DMR").Select
End If
Next r
End Sub
If there is anything else I can provide, or some way of conveying the information I am trying to acquire more clearly, please don't hesitate to ask!
Thank-you so much for your patience!
Veronica
This searches the desired range (G3:EP7002) in a loop to find all instances and will drop it in Sheet(Search) starting at A5:B5. It lacks the error checking of user3578951 but I leave you to figure that out ^_^
Private Sub CommandButton1_Click()
Dim dmr As Worksheet
Dim strSearch As String
Dim f As Variant
Dim fAddress As String
Dim fRow As Long
Dim cellA As Variant
Dim cellB As Variant
Set dmr = Worksheets("DMR")
pasteRowIndex = 5
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
With dmr.Range("G3:EP7002")
Set f = .Find(strSearch, LookIn:=xlValues)
If Not f Is Nothing Then
fAddress = f.Address
Do
fRow = f.Row
cellA = dmr.Cells(fRow, 1).Value
cellD = dmr.Cells(fRow, 4).Value
Sheets("SEARCH").Cells(pasteRowIndex, 1) = cellA
Sheets("SEARCH").Cells(pasteRowIndex, 2) = cellD
pasteRowIndex = pasteRowIndex + 1
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> fAddress
End If
End With
End Sub
Since you're just searching if a value exists, you can shorten that code using the "Find" feature:
Private Sub CommandButton1_Click()
Dim rngCell As Range
Dim dmrWS As Worksheet, searchWS As Worksheet
Dim lngLstRow As Long, strSearchRow As Long, lngLstCol As Long
Dim strSearch As String
Dim r As Long
Dim x As Variant
Dim searchNewRow As Integer
Set dmrWS = Sheets("DMR")
Set searchWS = Sheets("SEARCH")
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
With dmrWS
On Error GoTo ErrorHandler
strSearchRow = .Cells.Find(what:=strSearch, LookAt:=xlWhole).Row
End With
If strSearchRow > 0 Then 'If there was a value found
searchNewRow = searchWS.UsedRange.Rows.Count
With searchWS
.Range(.Cells(searchNewRow, 1), .Cells(searchNewRow, 4)).Value = dmrWS.Range(dmrWS.Cells(strSearchRow, 1), dmrWS.Cells(strSearchRow, 4)).Value
End With
End If
ErrorHandler:
MsgBox (strSearch & " was not found.")
End Sub
I think that does what you want. If the string is found in "DMR" sheet, say on row 9, it'll copy A9:D9 to the next empty row in "Search" sheet. Please let me know if this isn't quite what you're looking for.
Final answer to my request and this works great!
Private Sub CommandButton1_Click()
Dim dmr As Worksheet
Dim strSearch As String
Dim f As Variant
Dim fAddress As String
Dim fRow As Long
Dim cellA As Variant
Dim cellB As Variant
Worksheets("SEARCH").Range("A5:B200").ClearContents
Set dmr = Worksheets("DMR")
pasteRowIndex = 5
strSearch = InputBox("Please enter 5 digit document number to search for (e.g. 00002):", "Search Value")
If strSearch = vbNullString Then
MsgBox ("User canceled, or did not enter a value.")
Exit Sub
End If
With dmr.Range("G3:EP7002")
Set f = .Find(strSearch, LookIn:=xlValues)
If Not f Is Nothing Then
fAddress = f.Address
Do
fRow = f.Row
cellA = dmr.Cells(fRow, 1).Value
cellD = dmr.Cells(fRow, 4).Value
Sheets("SEARCH").Cells(pasteRowIndex, 1) = cellA
Sheets("SEARCH").Cells(pasteRowIndex, 2) = cellD
pasteRowIndex = pasteRowIndex + 1
Set f = .FindNext(f)
Loop While Not f Is Nothing And f.Address <> fAddress
End If
If f Is Nothing Then
MsgBox ("The document number you've entered either does not appear in this tool, or is not cross referenced in any other document.")
Exit Sub
End If
End With
End Sub