I'm trying to load img from folder path, and populate listbox by dependent combobox selection
so far I have this code attached below
Private Sub ComboBox3_Change()
Private Sub UserForm_Initialize()
ComboBox1.RowSource = "EngType"
ComboBox2.Value = "Please Select Engine Type"
End Sub
Private Sub ComboBox1_Change()
If ComboBox1.Text = "IF" Then
ComboBox2.Value = ""
ComboBox2.RowSource = "IF"
ElseIf ComboBox1.Text = "GMT" Then
ComboBox2.RowSource = "GMT"
End If
End Sub
Private Sub ComboBox2_Change()
Dim dtRange As Range, itm As Variant, i As Long, ImgAdrs As String
ImgFile = ThisWorkbook.Path & "\IMG\IF"
If ComboBox2.Value <> "Please Select Engine Type" Then
UserForm.Image1.Picture = LoadPicture(ImgFile & ComboBox2.Text & ".jpg")
Else
UserForm.Image1.Picture = LoadPicture(ThisWorkbook.Path & "\IMG\IF\W_logo_color_pos_RGB.jpg")
End If
With Sheets("UserForm")
If ComboBox1.Text = "IF" Then
Set dtRange = .Range("J2:J2000").Find(What:=Me.ComboBox2.Value)
If Not dtRange Is Nothing Then
For Each itm In .Range("K2:N2000")
ListBox1.AddItem itm
Next
End If
ElseIf ComboBox1.Text = "GMT" Then
Set dtRange = .Range("E2:E2000").Find(What:=Me.ComboBox2.Value)
If Not dtRange Is Nothing Then
For Each itm In .Range("F2:H2000")
ListBox1.AddItem itm
Next
End If
End If
End With
End Sub
it populates a listbox but all the list populates in first column and I'm kept getting error from img when I select second combobox
any idea?
Related
I'm a beginner at VBA and I'm trying to create a button to search for previous data inserted in all workbooks, using information as client name or date see here. Could you help me with some tips? I attached my code until now below. Thanks in advance.
Private Sub data_consulta_Change()
If VBA.Len(data_consulta.Text) = 2 Then
data_consulta = data_consulta + "/"
End If
If VBA.Len(data_consulta.Text) = 5 Then
data_consulta = data_consulta + "/"
End If
End Sub
Private Sub limpar_Click()
cliente_nome = ""
data_consulta = ""
End Sub
Private Sub pesquisar_base_Click()
On Error GoTo Erro
'Dim pesquisa As String
'pesquisa = InputBox("Digite as informações da consulta!", "PESQUISAR")
Dim linha As Double
linha = 1
With Planilha1
Do
linha = linha + 1
If .Cells(linha, 2).Value = pesquisa Or .Cells(linha, 3).Value Or .Cells(linha, 4).Value Then
data_consulta = .Cells(linha, 2).Value
data_consulta = .Cells(linha, 4).Value
Exit Sub
End If
Loop Until .Cells(linha, 2).Value = ""
MsgBox "Informação não encontrada!", vbInformation, "PESQUISA"
End With
Exit Sub
Erro:
MsgBox "Digite as informações da consulta!", cvcritical, "ERRO"
End Sub
Private Sub UserForm_Initialize()
data_consulta = VBA.Date
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub CommandButton1_Click()
'...
End Sub
Private Sub cliente_nome_Change()
'...
End Sub
Private Sub Label1_Click()
'...
End Sub
Private Sub Label2_Click()
'...
End Sub
enter image description hereI have a spreadsheet that has 3 checkbox options for each row, I have created a VBA to disable the other 2 checkboxes once a checkbox is created (so that only 1 checkbox can be checked), however my solution only works for one row and I need some help in rewriting this so that it will apply to all rows please. (I'm new to VBA).
The code I have used is this:
Private Sub CheckBox1_Click()
If CheckBox1.Value = True Then
CheckBox2.Value = False
CheckBox2.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox2.Value = False
CheckBox2.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox3.Value = False
CheckBox3.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox3.Value = False
CheckBox3.Enabled = True
End If
End Sub
Private Sub CheckBox3_Click()
If CheckBox3.Value = True Then
CheckBox1.Value = False
CheckBox1.Enabled = False
CheckBox2.Value = False
CheckBox2.Enabled = False
Else
CheckBox1.Value = False
CheckBox1.Enabled = True
CheckBox2.Value = False
CheckBox2.Enabled = True
End If
End Sub
You should probably just use Radios it would be a lot simpler.
If you are intent on doing this you will need to delete all your boxes and then put this code in. It will create and name your boxes and assign them code on click.
Alright, This needs to go in your Sheet module:
Sub Worksheet_Activate()
'Change Module2 to whatever the module name you are using is.
Module2.ActivateCheckBoxes ActiveSheet
End Sub
This next stuff will go into the module you're referencing from the Worksheet Module.
Sub ActivateCheckBoxes(sht As Worksheet)
If sht.CheckBoxes.Count = 0 Then
CreateCheckBoxes sht
End If
Dim cb As CheckBox
For Each cb In sht.CheckBoxes
'You may be able to pass sht as an object, It was giving me grief though
cb.OnAction = "'Module2.CheckBoxClick """ & cb.name & """, """ & sht.name & """'"
Next cb
End Sub
Sub CreateCheckBoxes(sht As Worksheet)
Dim cell As Range
Dim chkbox As CheckBox
With sht
Dim i As Long
Dim prevrow As Long
prevrow = 0
For Each cell In .Range("B2:D5") 'Change this to whatever range you want.
If prevrow < cell.row Then
prevrow = cell.row
i = 0
End If
Set chkbox = .CheckBoxes.Add(cell.Left, cell.Top, 30, 6)
With chkbox
.name = "CheckBox" & i & "_" & cell.row
.Caption = ""
End With
i = i + 1
Next cell
End With
End Sub
Sub CheckBoxClick(chkname As String, sht As String)
Dim cb As CheckBox
With Worksheets(sht)
For Each cb In .CheckBoxes
If Split(cb.name, "_")(1) Like Split(chkname, "_")(1) And Not cb.name Like chkname Then
cb.Value = -4146
End If
Next cb
End With
End Sub
You do not say anything about your sheet check boxes type... Please, test the next solution. It will be able to deal with both sheet check boxes type:
Copy this two Subs in a standard module:
Public Sub CheckUnCheckRow(Optional strName As String)
Dim sh As Worksheet, s As CheckBox, chK As OLEObject ' MSForms.CheckBox
Set sh = ActiveSheet
If strName <> "" Then
Set chK = sh.OLEObjects(strName) '.OLEFormat.Object
solveCheckRow chK.Object.Value, sh, Nothing, chK
Else
Set s = sh.CheckBoxes(Application.Caller)
solveCheckRow s.Value, sh, s
End If
End Sub
Sub solveCheckRow(boolVal As Long, sh As Worksheet, chF As CheckBox, Optional chK As OLEObject)
Dim s As CheckBox, oObj As OLEObject, iCount As Long
If Not chF Is Nothing Then
For Each s In sh.CheckBoxes
If chF.TopLeftCell.Address <> s.TopLeftCell.Address Then
If s.TopLeftCell.Row = chF.TopLeftCell.Row Then
s.Value = IIf(boolVal = -4146, 1, -4146): iCount = iCount + 1
If iCount = 2 Then Exit Sub
End If
End If
Next
ElseIf Not chK Is Nothing Then
For Each oObj In sh.OLEObjects
If oObj.TopLeftCell.Address <> chK.TopLeftCell.Address Then
If oObj.TopLeftCell.Row = chK.TopLeftCell.Row Then
boolStopEvents = True
oObj.Object.Value = IIf(boolVal = 0, True, False): iCount = iCount + 1
boolStopEvents = False
If iCount = 2 Then Exit Sub
End If
End If
Next
End If
End Sub
For case of Form check boxes type:
a). Manually assign the first sub to all your Form Type check boxes (right click - Assign Macro, choose CheckUnCheckRow and press OK).
b). Automatically assign the macro:
Dim sh As Worksheet, s As CheckBox
Set sh = ActiveSheet ' use here your sheet keeping the check boxes
For Each s In sh.CheckBoxes
s.OnAction = "'" & ThisWorkbook.Name & "'!CheckUnCheckRow"
Next
End Sub
If your check boxes have already assigned a macro, adapt CheckUnCheckRow, in Form check boxes section, to also call that macro...
For case of ActiveX check boxes:
a). Create a Public variable on top of a standard module (in the declarations area):
Public boolStopEvents
b). Manually adapt all your ActiveX check boxes Click or Change event, like in the next example:
Private Sub CheckBox1_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox1"
End Sub
Private Sub CheckBox2_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox2"
End Sub
Private Sub CheckBox3_Click()
If Not boolStopEvents Then CheckUnCheckRow "CheckBox3"
End Sub
and so on...
c). Or do all that with a click, using the next piece of code:
Sub createEventsAllActiveXCB()
Dim sh As Worksheet, oObj As OLEObject, strCode As String, ButName As String
Set sh = ActiveSheet 'use here your sheet keeping ActveX check boxes
For Each oObj In sh.OLEObjects
If TypeName(oObj.Object) = "CheckBox" Then
ButName = oObj.Name
strCode = "Private Sub " & ButName & "_Click()" & vbCrLf & _
" If Not boolStopEvents Then CheckUnCheckRow """ & ButName & """" & vbCrLf & _
"End Sub"
addClickEventsActiveXChkB sh, strCode
End If
Next
End Sub
Anyhow, the code cam be simplified in order to deal with only a type of such check boxes. If you intend to use it and looks too bushy, I can adapt it only for the type you like. Like it is, the code deals with both check box types, if both exist on the sheet...
Save the workbook and start playing with the check boxes. But, when you talk about check boxes on a row, all tree of them must have the same TopLeftCell.Row...
I have Microsoft Office 365 2019.
First of all i want to tell how code works:
Insert Note.
Click on Cell who has inserted Note.
Press Ctrl+N
Then you will see "PopUp-Menu".
I have VBA code (to work put in ThisWorkbook):
Private Sub Workbook_Open()
Application.OnKey "^{n}", CodeName & ".ContextMenu"
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "^{n}"
End Sub
Private Sub ContextMenu()
If ActiveCell Is Nothing Then Exit Sub
If ActiveCell.Comment Is Nothing Then Exit Sub
On Error Resume Next 'Can be and without inadequate to, but then with brute force(cycle) CommandBars.
Dim cb As CommandBar
Set cb = Application.CommandBars("vbaPopup")
If cb Is Nothing Then CreateContextMenu
Application.CommandBars("vbaPopup").ShowPopup
End Sub
Private Sub CreateContextMenu()
Dim a1_icon, a1_file, a2, a3, i&, m$, p$, f$: m = CodeName & ".": p = Path & "\Image\"
a1_icon = Array(76, 72, 178, 53)
a1_file = Array("NoteZoom_200x110.jpg", "NoteZoom_600x400.jpg", "Full Screen.jpg", "NoteZoom_InputBox.jpg", "Copy Text.jpg")
a2 = Array("NoteZoom 200x110", "NoteZoom 600x400", "Note <Full Screen>", "NoteZoom InputBox", "Скопировать текст примечания")
a3 = Array("NoteZoom1", "NoteZoom2", "NoteZoom3", "NoteZoom_InputBox", "NoteTextToClipboard")
With Application.CommandBars.Add("vbaPopup", msoBarPopup, , True) 'You can also not do to make the context menu temporary.
For i = 0 To UBound(a1_file) 'Ubound(a1_ico)
With .Controls.Add
f = p & a1_file(i)
If Len(Dir(f)) Then
.Picture = LoadPicture(f)
Else
.FaceId = a1_icon(i) 'If the file is not found, the icon. But it's not necessary.
End If
.Caption = a2(i)
.OnAction = m & a3(i)
End With
Next
End With
End Sub
Private Sub NoteZoom1(): NoteChangeSize 200, 110: End Sub
Private Sub NoteZoom2(): NoteChangeSize 600, 400: End Sub
Private Sub NoteZoom3()
With ActiveWindow.VisibleRange
NoteChangeSize .Width, .Height, True
'With .Resize(.Rows.Count - 1, .Columns.Count - 1) 'Without check
' NoteChangeSize .Width, .Height, True
'End With
End With
End Sub
Private Sub NoteChangeSize(w!, h!, Optional scr As Boolean)
With ActiveCell.Comment.Shape
.Width = w: .Height = h
If scr Then .Top = 0: .Left = 0: .Visible = msoTrue
End With
End Sub
'To create a `Note` with `InputBox`.
Private Sub NoteZoom_InputBox()
'Ниже 2 строчки для проверки наличия `Примечания`.
If ActiveCell Is Nothing Then Exit Sub
If ActiveCell.Comment Is Nothing Then Exit Sub
Dim lH As Long 'height
Dim lW As Long 'width
lH = Application.InputBox("Choose the HEIGHT of the notes ")
lW = Application.InputBox("Choose the WIDTH of the notes ")
With ActiveCell.Comment
' .Text Text:="Note:" & Chr(10) & ""
.Shape.Height = lH
.Shape.Width = lW
End With
End Sub
Private Sub NoteTextToClipboard()
With New DataObject
.SetText ActiveCell.Comment.Text
.PutInClipboard
End With
End Sub
For more details you can download my Excel Workbook to see how it's implemented!
Also i find code on this site Ron de Bruin. I wish to add "Submenu" in my "Menu"! Wrote out only those codes which can help to create "Submenu". But how to combine I don't know!?
Dim MenuItem As CommandBarPopup
'Add PopUp menu
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
MenuBar:=False, Temporary:=True)
'Add menu with two buttons
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "My Special Menu"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1 in menu"
.FaceId = 71
.OnAction = "'" & ThisWorkbook.Name & "'!" & "TestMacro"
End With
In the end I want to get this:
0Key finally i find some solution for this. Right now it's looks like this:
Looks cool right? Download full code link.
How to make suggestions in Excel data validation list while typing. There are constraints in my request:
The list of items should be in another sheet, and must not be above in hidden rows.
Typing a phrase should narrow the list to all the items which contain the phrase.
Search should be case insensitive.
So after typing am we should hypothetically have a suggestion to pick up from Amelia, Camila, Samantha, provided that those girls' names are on the item list.
I have found a good solution here, however it does not filter the items with contains clause but begins with. I sum up the proposed solution here shortly.
We insert a Combo Box (ActiveX Control) to a sheet.
We right click on a sheet name > View code > and paste the VBA code in the sheet VBA editor:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Update by Extendoffice: 2018/9/21
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim xArr
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
If .ListFillRange = "" Then
xArr = Split(xStr, ",")
Me.TempCombo.List = xArr
End If
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9
Application.ActiveCell.Offset(0, 1).Activate
Case 13
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
I could not find a way to modify to change the search option from 'begins with' to contains.
The questions about autocomplete or autosuggest in validation list have been asked so far.
Excel data validation with suggestions/autocomplete
Excel 2010: how to use autocomplete in validation list
But neither of them contained answers which would satisfied the constraints I imposed.
Test file for download is here.
Try to add the following event (additionally the the other 2). Every time you enter something the code refreshes the ComboBox list.
Private Sub TempCombo_Change()
With Me.TempCombo
If Not .Visible Then Exit Sub
.Clear 'needs property MatchEntry set to 2 - fmMatchEntryNone
.Visible = False 'to refresh the drop down
.Visible = True
.Activate
Dim xStr As String, xArr As Variant
xStr = TempCombo.TopLeftCell.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
xArr = Split(xStr, Application.International(xlListSeparator))
Dim itm As Variant
For Each itm In xArr
If InStr(1, itm, .Value, vbTextCompare) > 0 Or .Value = "" Then
.AddItem itm
End If
Next itm
.DropDown
End With
End Sub
To overcome your first constraint, maybe you can assign a range to your combo box:
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim xArr
Dim i As Range
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("Combotest")
With Sheets("Test_list2")
Set i = .Range("A2:A" & .Range("A" & .Rows.Count).End(xlUp).Row)
End With
Combotest.ListFillRange = i.Address
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("Combotest")
With xCombox
.LinkedCell = "F2"
.Visible = True
End With
.
.
.
.
End Sub
After choosing item from ActiveX combobox by mouse click I would like the combobox to be closed and the item to be chosen.
Here is an example.
I have tried TempCombo_Click event but it is fired AFTER the TempCombo_Change event. And when I select item by click, my search string passed to TempCombo_Change event is empty. So I need something to preserve item selection in TempCombo_Change event.
I use modification of VBA code taken from Autocomplete suggestion in Excel data validation list again
Here is VBA exact code I use to generate the above example.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim xCombox As OLEObject
Dim xStr As String
Dim xWs As Worksheet
Dim xArr
Set xWs = Application.ActiveSheet
On Error Resume Next
Set xCombox = xWs.OLEObjects("TempCombo")
With xCombox
.ListFillRange = ""
.LinkedCell = ""
.Visible = False
End With
If Target.Validation.Type = 3 Then
Target.Validation.InCellDropdown = False
'Cancel = True
xStr = Target.Validation.Formula1
xStr = Right(xStr, Len(xStr) - 1)
If xStr = "" Then Exit Sub
With xCombox
.Visible = True
.Left = Target.Left
.Top = Target.Top
.Width = Target.Width + 5
.Height = Target.Height + 5
.ListFillRange = xStr
If .ListFillRange = "" Then
xArr = Split(xStr, Application.International(xlListSeparator))
Me.TempCombo.List = xArr
End If
.LinkedCell = Target.Address
End With
xCombox.Activate
Me.TempCombo.DropDown
End If
End Sub
Private Sub TempCombo_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 9 'tab
Application.ActiveCell.Offset(0, 1).Activate
Case 13 'enter
Application.ActiveCell.Offset(1, 0).Activate
End Select
End Sub
Private Sub TempCombo_Change()
If Me.TempCombo = "" Then Exit Sub
ActiveSheet.OLEObjects(1).ListFillRange = ""
ActiveSheet.OLEObjects("TempCombo").Object.Clear
ThisWorkbook.ActiveSheet.OLEObjects("TempCombo").Activate
With Me.TempCombo
If Not .Visible Then Exit Sub
.Visible = False 'to refresh the drop down
.Visible = True
.Activate
'Dump the range into a 2D array
Dim Arr2D As Variant
Arr2D = [RangeItems].Value
'Declare and resize the 1D array
Dim Arr1D As Variant
ReDim Arr1D(1 To UBound(Arr2D, 1))
'Convert 2D to 1D
Dim i As Integer
For i = 1 To UBound(Arr2D, 1)
Arr1D(i) = Arr2D(i, 1)
Next
Dim itm As Variant 'itm is for iterate purpose
Dim ShortItemList() As Variant 'ShortItemList() is a variable which stores only filtered items
i = -1
For Each itm In Arr1D
If InStr(1, itm, .Value, vbTextCompare) > 0 Or .Value = "" Then
Debug.Print itm
i = i + 1
ReDim Preserve ShortItemList(i)
ShortItemList(i) = itm
End If
Next itm
.DropDown
End With
On Error Resume Next 'if we filter too much, there will be no items on ShortItemList
ThisWorkbook.ActiveSheet.OLEObjects("TempCombo").Object.List = ShortItemList
End Sub
This line in the TempCombo_Click event solved the problem:
ActiveCell.Value = ThisWorkbook.ActiveSheet.OLEObjects("TempCombo").Object.Value