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.
Related
I have a seemingly simple goal to turn the content of column B into comments of column A.
I have tried using the following code from #Dy.Lee mentioned here, but unfortunately it gives me a Run-time error '1004' Application-defined or object-defined error...
Sub Komentari()
Dim rngDB As Range, rngComent As Range
Dim rng As Range
Dim cm As Comment, i As Integer
Set rngComent = Range("A1:A50")
Set rngDB = Range("B1:B50")
For Each rng In rngComent
i = i + 1
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
Set cm = rng.AddComment
With cm
.Visible = False
.Text Text:=rngDB(i).value
End With
Next rng
End Sub
Can somebody, please, spot the mistake or suggest a better solution for this?
I'd go this way (explanations in comments):
Public Sub Komentari()
Dim rng As Range
With Range("A1:A50") ' reference comments range
.ClearComments ' clear its comments
For Each rng In .Offset(, 1).SpecialCells(xlCellTypeConstants) ' loop through refrenced range adjacent not empty cells
With rng.Offset(, -1).AddComment ' add comment to current rng corresponding comment range cell
.Visible = False
.Text rng.Value2
End With
Next
End With
End Sub
Sub Komentari()
Dim rngDB As Range, rngComent As Range
Dim rng As Range
Dim cm As Comment, i As Integer
Set rngComent = Range("A1:A50")
For Each rng In rngComent
i = i + 1
If Not rng.Range("B1").Comment Is Nothing Then
rng.Range("B1").Comment.Delete
End If
rng.Range("B1").AddComment (rng.Text)
Next rng
End Sub
Something like the following where you can use Offset to get the adjacent range, you drop the = when adding the text value to the comment, test that there is actually a value present first as well, and ensure you state the sheet to avoid implicit Activesheet reference.
Option Explicit
Public Sub Komentari()
Dim rngComent As Range
Dim rng As Range, cm As Comment
With ThisWorkbook.Worksheets("Sheet1")
Set rngComent = .Range("A1:A50")
For Each rng In rngComent
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
Set cm = rng.AddComment
With cm
.Visible = False
If rng.Offset(, 1) <> vbNullString Then .Text rng.Offset(0, 1).Value
End With
Next
End With
End Sub
Rather than add blank comments you could also flip this round to:
Option Explicit
Public Sub Komentari()
Dim rngComent As Range
Dim rng As Range, cm As Comment
With ThisWorkbook.Worksheets("Sheet1")
Set rngComent = .Range("A1:A50")
For Each rng In rngComent
If Not rng.Comment Is Nothing Then
rng.Comment.Delete
End If
If rng.Offset(, 1) <> vbNullString Then
Set cm = rng.AddComment
With cm
.Visible = False
.Text rng.Offset(0, 1).Value
End With
End If
Next
End With
End Sub
I am creating a macro that is supposed to separate and add new worksheets based off one worksheet with all the data in it.
It won't run and I'm not sure why.
My code keeps hitting a Run Time Error '9': Script out of range. I'm not sure if it has something to do with the first sub or the second sub.
The error occurs on line 16:
Set wsMain = wbMain.Sheets("MAIN")
First sub:
Option Explicit
Sub main()
Dim wbMain As Workbook
Dim wsMain As Worksheet
Dim rngMain As Range
Dim RngCategoryOne As Range
Dim RngCategoryTwo As Range
Dim RngCategoryThree As Range
Dim RngCategoryFour As Range
Dim RngCategoryFive As Range
Dim RngCategorySix As Range
Dim rng As Range
Dim SheetNames As Variant
Dim str As Variant
Set wbMain = ActiveWorkbook
Set wsMain = wbMain.Sheets("MAIN")
Set rngMain = wsMain.Range("F2:F3000")
For Each rng In rngMain
Select Case rng
Case "HO NMX_AMO", "HO NMX_EUR", "WTI NMX", "DIESEL OHR EIA_AMO"
If RngCategoryOne Is Nothing Then
Set RngCategoryOne = rng
Else
Set RngCategoryOne = Union(rng, RngCategoryOne)
End If
Case "WTI NMX_AMO"
If RngCategoryTwo Is Nothing Then
Set RngCategoryTwo = rng
Else
Set RngCategoryTwo = Union(rng, RngCategoryTwo)
End If
Case "NG HH NMX"
If RngCategoryThree Is Nothing Then
Set RngCategoryThree = rng
Else
Set RngCategoryThree = Union(rng, RngCategoryThree)
End If
Case "RBOB NMX_EUR", "RBOB NMX_AMO"
If RngCategoryFour Is Nothing Then
Set RngCategoryFour = rng
Else
Set RngCategoryFour = Union(rng, RngCategoryFour)
End If
Case "GO ICE_AMO"
If RngCategoryFive Is Nothing Then
Set RngCategoryFive = rng
Else
Set RngCategoryFive = Union(rng, RngCategoryFive)
End If
Case "C3 CONW INW OPIS_APO, C3 MBEL TET OPIS_APO"
If RngCategorySix Is Nothing Then
Set RngCategorySix = rng
Else
Set RngCategorySix = Union(rng, RngCategorySix)
SheetNames = Array("AT, LB, LC, AS", "AO", "LN", "RF, RA", "ULA2", "8K, BO")
For Each str In SheetNames
Call AddNewWorksheet(wbMain, str)
Next str
wbMain.Sheets("AT, LB, LC, AS").Range("A1:A" & RngCategoryOne.Count) = RngCategoryOne.Value
wbMain.Sheets("AO").Range("A1:A" & RngCategoryTwo.Count) = RngCategoryTwo.Value
wbMain.Sheets("LN").Range("A1:A" & RngCategoryThree.Count) = RngCategoryThree.Value
wbMain.Sheets("RF, RA").Range("A1:A" & RngCategoryFour.Count) = RngCategoryFour.Value
wbMain.Sheets("ULA2").Range("A1:A" & RngCategoryFive.Count) = RngCategoryFive.Value
wbMain.Sheets("8K, BO").Range("A1:A" & RngCategorySix.Count) = RngCategorySix.Value
wsMain.Activate
wsMain.Range("A1").Select
End If
End Select
Next
End Sub
Second Sub:
Sub AddNewWorksheet(ByRef wb As Workbook, ByVal wsName As Variant)
With wb.Sheets
.Add(after:=wb.Sheets(.Count)).Name = wsName
End With
End Sub
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 need to create an IF AND THEN statement in my vba. I've tried this code below and although I get no errors it doesn't work (ie: nothing happens when I run the macro):
Sub PrintAll()
Dim BrokerCell As Range
Dim Rng As Range
Dim Wks As Worksheet
Set Wks = Worksheets("PRINT PAGE")
If Range("$A$5").Value = "Company 1" Then
Set Rng = ThisWorkbook.Names("Company1").RefersToRange
ElseIf Range("$A$5").Value = "Company2" Then
Set Rng = ThisWorkbook.Names("Company2").RefersToRange
Else: Set Rng = ThisWorkbook.Names("Company3").RefersToRange
End If
For Each BrokerCell In Rng
If BrokerCell <> "" AND "$Q$5" > "0" Then
Wks.Range("$B$5").Value = BrokerCell.Text
Wks.PrintOut
End If
Next BrokerCell
End Sub
The macro works without the
AND "$Q$5" > "0"
so clearly I'm doing something wrong here.
You probably mean:
If BrokerCell <> "" And Range("$Q$5").Value > 0
You're comparing the literal string "$Q$5" to the literal string "0".