I tested the following code in Excel 2016. But I encounter an
error message of 1004
and the code does not work.
Error line:
Me.TextBox1.Text = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value, xRg, 2, False))
Private Sub UserForm_Click()
Dim xRg As Range
Private Sub UserForm_Initialize()
Set xRg = Worksheets("Sheet1").Range("A2:B8")
Me.ComboBox1.List = xRg.Columns(1).Value
End Sub
Private Sub ComboBox1_Change()
Me.TextBox1.Text = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value,
xRg, 2, False)
End Sub
It seems that xRg is declared outside of the scope of the ComboBox1_Change event. Thus, the Combobox1_Change() does not access it. Try to declare it within:
Private Sub ComboBox1_Change()
Dim xRg As Range
Set xRg = Worksheets("Sheet1").Range("A2:B8")
Me.TextBox1.Text = Application.WorksheetFunction.VLookup(Me.ComboBox1.Value, _
xRg, 2, False)
End Sub
As mentioned by #Vityata here, you will need to assign the xRg variable within your current code block as it has no reference to it.
As an addition to that though, I would advise ditching the vlookup application function in place of assignment by the combobox index: Me.ComboBox1.ListIndex and use that as the reference for the row in xRg:
Me.TextBox1.Value = xRg.Cells(Me.ComboBox1.ListIndex + 1, 2).Value
The ComboBox.ListIndex property is a 0 based array so I have added 1 on to get the proper row assignment.
Related
Hopefully a simple question. I have some simple code for a combo box that runs during Combobox_Change().
Private Sub ComboBox1_Change()
If ComboBox1.Value = "" Then
Label3.Caption = ""
Else
Label3.Caption = Worksheets("Currency").Cells.Find(UserForm1.ComboBox1.Value).Offset(0, -1).Value
End If
End Sub
Private Sub UserForm_Initialize()
ComboBox1.List = [Currency!C2:C168].Value
Label3.Caption = ""
End Sub
But when you enter something that isn't part of the declared Combobox range it throws up a runtime error 'Object variable not set'. How do I fool proof this combobox and when any irregular entry is made that isn't part of the selection range for it to revert back to "" empty? Or pop up with an error box stating "Invalid Input"?
If Find fails to find anything it returns a null object. That returned object has no methods or properties so you can't take the offset() or value of it. To work around this you need to separate out the returned object and its methods/properties and test the validity of the returned object.
Private Sub ComboBox1_Change()
If ComboBox1.Value = "" Then
Label3.Caption = ""
Else
Dim fndrng As Range
'Get just the find range
Set fndrng = Worksheets("Currency").Cells.Find(UserForm1.ComboBox1.Value)
'Make sure find found something
If Not fndrng Is Nothing Then
'use the methods/properties we want
Label3.Caption = fndrng.Offset(0, -1).Value
Else
MsgBox "Selection not found", vbOKOnly, "Error"
End If
End If
End Sub
Private Sub UserForm_Initialize()
ComboBox1.List = [Currency!C2:C168].Value
Label3.Caption = ""
End Sub
I have a data in column B which is dynamic ( cities can be in any order) , what I am looking is for a VBA code to fill color in the rectangle shape ( I have renamed rectangle shapes to corresponding city names). based on the color of corresponding city.
This is sample list, and actual data can be long, Hence was looking for an automated script to do this task.
Please, try the next approach. It will use a class, able to trigger the interior color change:
Insert a class module, name it "clsCelColorCh", copy and place the next code:
Option Explicit
Private WithEvents cmBar As Office.CommandBars
Private cellsCountOK As Boolean, arrCurColor(), arrPrevColor(), sCellAddrss() As String
Private sVisbRngAddr As String, i As Long, objSh As Worksheet, cel As Range, rngBB As Range
Public Sub ToSheet(sh As Worksheet)
Set objSh = sh
End Sub
Public Sub StartWatching()
Set cmBar = Application.CommandBars
End Sub
Private Sub Class_Initialize()
cellsCountOK = False
End Sub
Private Sub cmBar_OnUpdate()
If Not ActiveSheet Is objSh Then Exit Sub
Set rngBB = Intersect(ActiveWindow.VisibleRange, objSh.Range("B:B"))
If rngBB Is Nothing Then Exit Sub
If sVisbRngAddr <> rngBB.Address And sVisbRngAddr <> "" Then
Erase sCellAddrss: Erase arrCurColor: Erase arrPrevColor
sVisbRngAddr = "": cellsCountOK = False
End If
i = -1
On Error Resume Next
For Each cel In rngBB.cells
ReDim Preserve sCellAddrss(i + 1)
ReDim Preserve arrCurColor(i + 1)
sCellAddrss(i + 1) = cel.Address
arrCurColor(i + 1) = cel.Interior.Color
If arrPrevColor(i + 1) <> arrCurColor(i + 1) Then
If cellsCountOK = True Then 'call the pseudo event Sub
CallByName objSh, "Cell_ColorChange", VbMethod, cel
arrPrevColor(i + 1) = arrCurColor(i + 1)
End If
End If
i = i + 1
If i + 1 >= rngBB.cells.count Then
cellsCountOK = True
ReDim Preserve arrPrevColor(UBound(arrCurColor))
arrPrevColor = arrCurColor
End If
arrPrevColor(i + 1) = arrCurColor(i + 1)
Next
On Error GoTo 0
sVisbRngAddr = rngBB.Address
End Sub
Copy the next code in the sheet to monitor color changes code module (right click on the sheet name and choose View Code):
Option Explicit
Private ColorChEventMonitor As clsCelColorCh
Public Sub Cell_ColorChange(Target As Range)
Dim sh As Shape
On Error Resume Next
Set sh = Me.Shapes(Target.Value)
On Error GoTo 0
If Not sh Is Nothing Then
sh.Fill.ForeColor.RGB = Target.Interior.Color
Else
MsgBox "No shape named as """ & Target.Value & """ in this sheet..."
End If
End Sub
Private Sub Worksheet_Activate()
StartEventWatching
End Sub
Private Sub Worksheet_Deactivate()
StopEventWatching
End Sub
Private Sub StartEventWatching()
Set ColorChEventMonitor = New clsCelColorCh
ColorChEventMonitor.ToSheet Me
ColorChEventMonitor.StartWatching
End Sub
Private Sub StopEventWatching()
Set ColorChEventMonitor = Nothing
End Sub
Deactivate the sheet in discussion (go on a different sheet) and go back. I this way, the sheet Activate event starts the color change monitoring.
It does it for color changes in column "B:B".
In order to see it working, of course, there must be so many shapes as records in column "B:B", named exactly like the cells value. Anyhow, if a cell value does not match any shape, no error will be raised, a message mentioning that a correspondent shape does not exist will appear.
The pseudo event is triggered when you select another cell. Sometimes, it is triggered only by simple changing the color, but not always...
Please, test it and send some feedback.
Is there any way to delete named ranges used in chart series when the chart is being deleted?
I use named ranges quite extensively in my daily work, also for charting. When I create charts I often name data ranges and THEN use them for chart series.
I am looking for a way to delete USED named ranges WHEN I delete the chart. I thought about chart "delete" event, but I cannot find any info about it (does it even exist???).
The second issue is how to determine which ranges have been used for chart series? Deleting the named ranges is easy, but how to actually determine, which ranges have been used in chart series?
All help is MUCH appreciated. Apologies but I cannot provide you with any code, as I have no idea how to set things up
Try the next code please. The USED named ranges cannot be extract directly. I used a trick to extract the ranges form SeriesCollection formula. Then compare them with names RefersToRange.Address and delete the matching name. It (now) returns a boolean value in case of match (only to see it in Immediate Window), but not necessary for your purpose. The code also delete the invalid names (having their reference lost).
Edited: I made some researches and I am afraid it is not possible to create a BeforeDelete event... It is an enumeration of events able to be created for a chart object, but this one is missing. I like to believe that I found a solution for your problem, respectively:
Create a class able to enable BeforeRightClick event. Name it CChartClass and write the next code:
Option Explicit
Public WithEvents ChartEvent As Chart
Private Sub ChartEvent_BeforeRightClick(Cancel As Boolean)
Dim msAnswer As VbMsgBoxResult
msAnswer = MsgBox("Do you like to delete the active chart and its involved Named ranges?" & vbCrLf & _
" If yes, please press ""Yes"" button!", vbYesNo, "Chart deletion confirmation")
If msAnswer <> vbYes Then Exit Sub
Debug.Print ActiveChart.Name, ActiveChart.Parent.Name
testDeleteNamesAndChart (ActiveChart.Parent.Name)
End Sub
Create another class able to deal with workbook and worksheet events, name it CAppEvent and copy the next code:
Option Explicit
Public WithEvents EventApp As Excel.Application
Private Sub EventApp_SheetActivate(ByVal Sh As Object)
Set_All_Charts
End Sub
Private Sub EventApp_SheetDeactivate(ByVal Sh As Object)
Reset_All_Charts
End Sub
Private Sub EventApp_WorkbookActivate(ByVal Wb As Workbook)
Set_All_Charts
End Sub
Private Sub EventApp_WorkbookDeactivate(ByVal Wb As Workbook)
Reset_All_Charts
End Sub
Put the next code in a standard module (need to create a classes array in order to start the event for all existing sheet embedded charts):
Option Explicit
Dim clsAppEvent As New CAppEvent
Dim clsChartEvent As New CChartClass
Dim clsChartEvents() As New CChartClass
Sub InitializeAppEvents()
Set clsAppEvent.EventApp = Application
Set_All_Charts
End Sub
Sub TerminateAppEvents()
Set clsAppEvent.EventApp = Nothing
Reset_All_Charts
End Sub
Sub Set_All_Charts()
If ActiveSheet.ChartObjects.Count > 0 Then
ReDim clsChartEvents(1 To ActiveSheet.ChartObjects.Count)
Dim chtObj As ChartObject, chtnum As Long
chtnum = 1
For Each chtObj In ActiveSheet.ChartObjects
Set clsChartEvents(chtnum).ChartEvent = chtObj.Chart
chtnum = chtnum + 1
Next
End If
End Sub
Sub Reset_All_Charts()
' Disable events for all charts
Dim chtnum As Long
On Error Resume Next
Set clsChartEvent.ChartEvent = Nothing
For chtnum = 1 To UBound(clsChartEvents)
Set clsChartEvents(chtnum).ChartEvent = Nothing
Next ' chtnum
On Error GoTo 0
End Sub
Sub testDeleteNamesAndChart(strChName As String)
Dim rng As Range, cht As Chart, sFormula As String
Dim i As Long, j As Long, arrF As Variant, nRng As Range
Set cht = ActiveSheet.ChartObjects(strChName).Chart
For j = 1 To cht.SeriesCollection.Count
sFormula = cht.SeriesCollection(j).Formula: Debug.Print sFormula
arrF = Split(sFormula, ",")
For i = 0 To UBound(arrF) - 1
If i = 0 Then
Set nRng = Range(Split((Split(sFormula, ",")(i)), "(")(1))
Else
Set nRng = Range(Split(sFormula, ",")(i)) '(1)
End If
Debug.Print nRng.Address, matchName(nRng.Address)
Next i
ActiveSheet.ChartObjects(strChName).Delete
End Sub
Private Function matchName(strN As String) As Boolean
Dim Nm As Name, strTemp As String
For Each Nm In ActiveWorkbook.Names
On Error Resume Next
strTemp = Nm.RefersToRange.Address
If Err.Number <> 0 Then
Err.Clear
Nm.Delete
Else
If strN = strTemp Then
Nm.Delete
matchName = True: Exit Function
End If
End If
On Error GoTo 0
Next
End Function
Use the next events code in the ThisWorkbook module:
Option Explicit
Private Sub Workbook_Open()
InitializeAppEvents
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
TerminateAppEvents
End Sub
Please confirm that it worked as you need
I have list of employees that I update and that's why I would like to gather names by VBA:
Private Sub CommercialBox_DropButtonClick()
Application.ScreenUpdating = False
Dim RngCom As Range
ThisWorkbook.Sheets("MAIN").CommercialBox.Clear
With ThisWorkbook.Sheets("Contact database")
For Each RngCom In .Range("B61:B77")
If RngCom.Value <> vbNullString Then ThisWorkbook.Sheets("MAIN").CommercialBox.AddItem RngCom.Value
Next RngCom
End With
Application.ScreenUpdating = True
End Sub
This is connected to DropButtonClick and works fine.
Now I need to connect also cell value to dropdown box so user will see what he has chosen. There is a small time gap between code is entering value to Worksheet. That's why this code does not work really:
Private Sub Worksheet_Change(ByVal Target As Range)
ThisWorkbook.Sheets("MAIN").CommercialBox.Value = ThisWorkbook.Sheets("Contact database").Range("I109").Value
End Sub
I have tried also this way, but it more like workaround than correct solution:
Private Sub CommercialBox_LostFocus()
ThisWorkbook.Sheets("MAIN").CommercialBox.Value = ThisWorkbook.Sheets("Contact database").Range("I109").Value
End Sub
How to repair that issue?
basically I have a userform which I would like to use to enter 2 data into another macro which I already have. The userform is as below:
Basically, I would like the OK button to be clicked and the data in the two boxes will be entered into another macro that I have. It would also be great if the OK button can help in a sense that it will prompt a warning if one of the boxes is not filled up.
So far, I do not have much of a code for this..
Private Sub UserForm_Click()
TextBox1.SetFocus
Sub Enterval()
End Sub
Private Sub TextBox1_Change()
Dim ID As String
ID = UserForm3.TextBox1.Value
End Sub
Private Sub TextBox2_Change()
Dim ID2 As String
ID2 = UserForm3.TextBox2.Value
End Sub
Private Sub OKay_Click()
Enterval
End Sub
Would appreciate any tips and help. Thanks!
My other macro
Private Sub CommandButton1_Click()
Dim Name As String
Dim Problem As Integer
Dim Source As Worksheet, Target As Worksheet
Dim ItsAMatch As Boolean
Dim i As Integer
Set Source = ThisWorkbook.Worksheets("Sheet1")
Set Target = ThisWorkbook.Worksheets("Sheet2")
Name = Source.Range("A3")
Problem = Source.Range("I13")
Do Until IsEmpty(Target.Cells(4 + i, 6)) ' This will loop down through non empty cells from row 5 of column 2
If Target.Cells(4 + i, 6) = Name Then
ItsAMatch = True
Target.Cells(4 + i, 7) = Problem ' This will overwrite your "Problem" value if the name was already in the column
Exit Do
End If
i = i + 1
Loop
' This will write new records if the name hasn't been already found
If ItsAMatch = False Then
Target.Cells(3, 6).End(xlDown).Offset(1, 0) = Name
Target.Cells(4, 6).End(xlDown).Offset(0, 1) = Problem
End If
Set Source = Nothing
Set Target = Nothing
End Sub
Thats the macro i have. As u said, i change the
othermacro
to CommandButton1_Click()
but it doesn't work
Quoting geoB except for one thing: when you .Show your UserForm from a main Sub, you can also .Hide it at the end and the macro that called it will continue its procedures.
Sub Okay_Click()
Dim sID1 As String, sID2 As String
' A little variation
If Me.TextBox1 = "" Or Me.TextBox2 = "" Then
MsgBox "Please fill all the input fields"
Exit Sub
End If
Me.Hide
End Sub
To address your TextBox, you can write in your main Sub UserForm3.TextBox1 for example
There is no need for an Enterval function. Instead, assume the user can read and follow instructions, then test whether that indeed is the case. Note that in your code ID and ID2 will never be used because they exist only within the scope of the subroutines in which they are declared and receive values.
To get started:
Sub Okay_Click()
Dim sID1 As String, sID2 As String
sID1 = UserForm3.TextBox1.Value
sID2 = UserForm3.TextBox2.Value
If Len(sID1 & vbNullString) = 0 Then
MsgBox "Box A is empty"
Exit Sub
End If
If Len(sID2 & vbNullString) = 0 Then
MsgBox "Box B is empty"
Exit Sub
End If
'Now do something with sID1, sID2
otherMacro(sID1, sID2)
End Sub
For your other macro, declare it like this:
Sub otherMacro(ID1, ID2)
...
End Sub
Also, the SetFocus method should occur in the form open event.