VBA find method seems to fail when I am trying to search for the value in specific column.
This code
Sub TargetR()
Dim CLL As Range
Dim TargetRange As Worksheet
Dim R As Range
Set CLL = ThisWorkbook.Worksheets(1).Range("J29")
Set TargetRange = ThisWorkbook.Worksheets(1)
Set R = TargetRange.Cells.Find(CLL.Value)
If Not (R Is Nothing) Then
Debug.Print R.Address
Else: Debug.Print "Empty"
End If
End Sub
works perfectly.
While the search limited by the column with keyword header fails:
Sub Target()
Dim CLL As Range
Dim TargetRange As Worksheet
Dim targetColumn As Range
Dim sColumn As Range
Dim R As Range
Set CLL = ThisWorkbook.Worksheets(1).Range("J29")
Set TargetRange = ThisWorkbook.Worksheets(1)
Set sColumn = TargetRange.Cells.Find("This Column")
Set targetColumn = sColumn.EntireColumn
Set R = targetColumn.Cells.Find(CLL.Value)
If Not (R Is Nothing) Then
Debug.Print R.Address
Else: Debug.Print "Empty"
End If
End Sub
Specifying search direction through xlByColunm does not help
Try the code below (explanation inside the code as comments):
Option Explicit
Sub Target()
Dim CLL As Range
Dim TargetRange As Worksheet
Dim sColumn As Range
Dim R As Range
Set CLL = ThisWorkbook.Worksheets(1).Range("J29")
Set TargetRange = ThisWorkbook.Worksheets(1)
Set sColumn = TargetRange.Cells.Find("This Column")
If Not sColumn Is Nothing Then ' <-- make sure Find was successful
Set R = sColumn.EntireColumn.Find(what:=CLL.Value, LookIn:=xlValues, lookat:=xlWhole)
If Not R Is Nothing Then
Debug.Print R.Address
Else: Debug.Print "Empty"
End If
Else ' Find failed to find "This Column"
MsgBox "Unable to find 'This Column'"
End If
End Sub
As I figured out, Find method do not work correctly if value that needs to be found contained in merged cell, and Find methoud applied only for the leftmost column, that contain part of that merged cell. For my VBA code to work properly, some additional merge check , and subsequent extension of search area was the answer
If sColumn.MergeCells Then
Set sColumn = Column.Resize(,Column.MergeArea.Columns.Count)
Related
I would like to atomatize an excel process using VBA.
The script has to go cell by cell in a selected area on Sheet3. Each cell contains a number or is blank.
The script will go and search for the value of each cell in a specific range on Sheet2. When it finds something the content of the whole row where it was found must go bold.
If it finds nothing it will just procede to the next cell.
After browsing here on stackoverflow and different guides I've managed to put together a script. It has no errors but it doesn't do Anything.
Sub MacroText()
Dim xlRng As Range
Dim rng As Range
Dim xlSht As Worksheet
Dim sht As Worksheet
Dim iLastRow As Integer
Dim iRow As Integer
Dim bFound As Boolean
Dim xCell As Range
Dim xlCell As Range
Dim valueToFind As String
bFound = False
Set sht = ActiveWorkbook.Worksheets("Sheet3")
Set xlSht = ActiveWorkbook.Worksheets("Sheet2")
Set rng = Selection
Set xlRng = ActiveWorkbook.Worksheets("Sheet2").Range("A:A")
iLastRow = xlSht.Range("A1").End(xlDown).Row
Set xlRng = xlSht.Range("A1:A" & iLastRow)
For Each xCell In rng
valueToFind = xCell.Value
For Each xlCell In xlRng
Worksheets("Sheet2").Activate
If xlCell.Value = valueToFind Then
bFound = True
iRow = xlCell.Row
Rows(iRow).Font.Bold = True
End If
If bFound = True Then Exit For
End
Next xlCell
Next xCell
End Sub
I am assuming that it has to be something with positioning within the code but I couldn't find any information for that.
After working on this for 12 hours I would really appreciate your help.
Cheers!
You could use the Find method to achieve this instead of the second loop
Sub MacroText()
Dim xlRng As Range
Dim rng As Range
Dim xlSht As Worksheet
Dim sht As Worksheet
Dim iLastRow As Long
Dim iRow As Long
Dim bFound As Boolean
Dim xCell As Range
Dim xlCell As Range
Dim valueToFind As String
Dim FoundRange As Range
bFound = False
Set sht = ActiveWorkbook.Worksheets("Sheet3")
Set xlSht = ActiveWorkbook.Worksheets("Sheet2")
Set rng = Selection
Set xlRng = ActiveWorkbook.Worksheets("Sheet2").Range("A:A")
iLastRow = xlSht.Range("A1").End(xlDown).Row
Set xlRng = xlSht.Range("A1:A" & iLastRow)
For Each xCell In rng
Set FoundRange = Nothing
Set FoundRange = xlRng.Find(what:=xCell.Value2)
If Not FoundRange Is Nothing Then
FoundRange.EntireRow.Font.Bold = True
End If
Next xCell
End Sub
For Each xlCell In xlRng
Worksheets("Sheet2").Activate
If xlCell.Value = valueToFind Then
xlCell.EntireRow.Font.Bold = True
End If
Next xlCell
I don't know what thing you are not getting, but I assumed that you are not getting desired row as bold. Replace the above code with your's for loop and run.
I didn't tested it, but am uncertain about not working.
I'm getting a type mismatch error when I try to run this code on opening the workbook, the line highlighted by the debugger is the 2nd to last, I've added a comment to the code so you know where.
The line where there is an error is the same as a line of code further up so I'm unsure why I get a type mismatch error following the second loop.
I have tested the two loops separately in their own modules and it works fine. It's when I combine them into 1 module and try to run on opening the workbook that I get the error.
Private Sub Workbook_Open()
Dim rng As Range
Dim InputRng As Range, OutRng As Range
Set dt = CreateObject("Scripting.Dictionary")
Set InputRng = Worksheets("AA").Range("C2:AF366")
Set OutRng = Worksheets("Unique Lists").Range("A2")
For Each rng In InputRng
If rng.Value <> "" Then
dt(rng.Value) = ""
End If
Next
OutRng.Range("A1").Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.Keys)
Application.CutCopyMode = False
Set dt = CreateObject("Scripting.Dictionary")
Set InputRng = Worksheets("CT").Range("C2:AF366")
Set OutRng = Worksheets("Unique Lists").Range("B2")
For Each rng In InputRng
If rng.Value <> "" Then
dt(rng.Value) = ""
End If
Next
'ERROR OCCURS ON THE NEXT LINE
OutRng.Range("A1").Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.Keys)
End Sub
For info: the code is designed to create 2 unique lists from cell ranges on different worksheets upon opening the workbook.
Make sure you have data in your "CT" worksheet. If all of your cells inside Range("C2:AF366") don't have any values, then dt.Count = 0 (since your Dictionary is Empty), and this will result with a run-time error.
You already defined and set OutRng, in Set OutRng = Worksheets("Unique Lists").Range("B2"), so in your error line you can use:
OutRng.Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.Keys)
That's one way to debug dictionary, when you are not sure what do you have inside- take a look at the last lines:
Option Explicit
Public Sub TestMe()
Dim rng As Range
Dim InputRng As Range, OutRng As Range
Dim dt As Object
Set dt = CreateObject("Scripting.Dictionary")
Set InputRng = Worksheets("AA").Range("C2:AF366")
Set OutRng = Worksheets("Unique Lists").Range("A2")
For Each rng In InputRng
If rng.Value <> "" Then
dt(rng.Value) = ""
End If
Next
OutRng.Range("A1").Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.keys)
Application.CutCopyMode = False
Set dt = CreateObject("Scripting.Dictionary")
Set InputRng = Worksheets("CT").Range("C2:AF366")
Set OutRng = Worksheets("Unique Lists").Range("B2")
For Each rng In InputRng
If rng.Value <> "" Then
dt(rng.Value) = ""
End If
Next
'ERROR OCCURS ON THE NEXT LINE
OutRng.Range("A1").Resize(dt.Count) = Application.WorksheetFunction.Transpose(dt.keys)
Dim dtKey As Variant
For Each dtKey In dt.keys
Debug.Print dtKey
Next dtKey
End Sub
Indeed, your code works quite ok when dt.Count is not 0.
I keep getting a type mismatch error and have tried changing the type a few times. I'm just trying to loop through each worksheet and a specified range to see if that word exists in every cell of that range.
Sub CheckWord()
Dim arrVar As Variant
Dim ws As Worksheet
Dim strCheck As Range
Set arrVar = ActiveWorkbook.Worksheets
'MsgBox (arrVar)
For Each ws In arrVar
If ws.Range("C9:G20").Value = "Word" Then
MsgBox (True)
End If
Next ws
End Sub
When you have a range with many columns, it creates an array.
Taking the array into consideration like so:
Sub CheckWord()
Dim arrVar As Variant
Dim ws As Worksheet
Dim strCheck As Range
Set arrVar = ActiveWorkbook.Worksheets
'MsgBox (arrVar)
For Each ws In arrVar
For each col in ws.Range("C9:G20").Cells
if col.Value = "Word" Then
MsgBox (True)
end if
End If
Next ws
End Sub
You can't get the value of ws.Range("C9:G20") and compare it to one string. You've selected multiple cells. If you want to return True when nay one of these cells contains "Word" or when all of them contain "Word" you'll need to iterate over them.
This is an example of how to return whether or not your range contains "Word" anywhere at least once
Function CheckWord()
Dim arrVar As Variant
Dim ws As Worksheet
Set arrVar = ActiveWorkbook.Worksheets
For Each ws In arrVar
Dim c
For Each c In ws.Range("C9:G20").Cells
If c = "Word" Then
CheckWord = True
Exit Function
End If
Next c
Next ws
End Function
Sub CheckWord()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
If Not ws.Range("C9:G20").Find(What:="Word", LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False) Is Nothing Then MsgBox "Found in " & ws.Name
Next ws
End Sub
As the title suggests, I can't figure out how to go to a cell using a variable for the row. I have attached the code I currently have and the commented section is what I'm having issues with, Thanks!
Private Sub Go_Click()
Dim id As Double
Dim qt As Double
Dim num As Double
Dim rngSearch As Range, rngFound As Range
id = Range("D4").Value
qt = Range("E4").Value
Set rngSearch = Range("A:A")
Set rngFound = rngSearch.Find(What:=id, LookIn:=xlValues, LookAt:=xlPart)
num = rngFound.Row
If rngFound Is Nothing Then
MsgBox "Stock ID Not Found"
Else
MsgBox rngFound.Row
'Range("O num.Value") = Range("O num.Value") - qt
End If
Range(rngFound.Row) = Range(rngFound.Row) - qt
End Sub
Perhaps
Range("O" & num).value=Range("O" & num).value-qt
I'm a newbie at vba so please excuse my ignorance. I created a macro that will run through a dropdown list and print for each name in the dropdown - and it works:
Sub PrintAll()
Dim Cell As Range
Dim Rng As Range
Dim Wks As Worksheet
Set Wks = Worksheets("PRINT PAGE")
Set Rng = ThisWorkbook.Names("Brokers").RefersToRange
For Each Cell In Rng
If Cell <> "" Then
Wks.Range("$B$5").Value = Cell.Text
Wks.PrintOut
End If
Next Cell
End Sub
However, the workbook has multiple worksheets to read from and therefore I need the vba to read from multiple ranges so I tried this
Sub PrintAll()
Dim Cell As Range
Dim Cell2 As Range
Dim Rng As Range
Dim Wks As Worksheet
Set Wks = Worksheets("PRINT PAGE")
If "$A$5" = "Company1" Then Rng = ThisWorkbook.Names("1Brokers").RefersToRange
ElseIf "$A$5" = "Company2" Then Rng = ThisWorkbook.Names("2Brokers").RefersToRange
Else: Set Rng = ThisWorkbook.Names("3Brokers").RefersToRange
End If
For Each Cell In Rng
If Cell <> "" Then
Wks.Range("$B$5").Value = Cell.Text
Wks.PrintOut
End If
Next Cell
End Sub
The problem is I keep getting "Compile error Else without If" on the If statement. Is there something wrong with how I'm setting up the If statement or with how I'm using it in the code?
This block compiles for me. Please test it. I have always start set in the after then in if.
Sub PrintAll()
Dim Cell As Range
Dim Cell2 As Range
Dim Rng As Range
Dim Wks As Worksheet
'Set Wks = Worksheets("PRINT PAGE")
If "$A$5" = "Company1" Then
Rng = ThisWorkbook.Names("1Brokers").RefersToRange
ElseIf "$A$5" = "Company2" Then
Rng = ThisWorkbook.Names("2Brokers").RefersToRange
Else
Set Rng = ThisWorkbook.Names("3Brokers").RefersToRange
End If
For Each Cell In Rng
If Cell <> "" Then
Wks.Range("$B$5").Value = Cell.Text
Wks.PrintOut
End If
Next Cell
End Sub
Use
If Range("$A$5").Value = "Company1"..
Similarly for "$A$5".
"$A$5" is just a string and you are comparing a string to a string. What you want is a range object
EDIT
Regarding the Error that you are getting, you have to use Then
The syntax is (Hiten004 post made me realize it)
If <Cond> Then
ElseIF <Cond> Then
End If
Rather than:
If "$A$5" = "Company1" Then Rng = ThisWorkbook.Names("1Brokers").RefersToRange
use:
If "$A$5" = "Company1" Then Set Rng = ThisWorkbook.Names("1Brokers").RefersToRange
There may be other problems in your code.