Is there any option in Excel VBA which allows me to change range of combobox?
See example
I would like to change number 5 in Variant/Variant(0 to 3, 0 to 5).
Combobox is filled with this code:
Private Sub UserForm_Activate()
Dim x As Range
With Worksheets("Distributori")
Set x = .Range("A2", .Range("F1000").End(xlUp))
End With
ComboBox1.RowSource = "Distributori!" & x.Address
ComboBox1.ListIndex = 0
Me.ComboBox1.TextColumn = 2
End Sub
Try the next (adapted) code, please:
Dim x As Range, arrList As Variant
With Worksheets("Distributori")
Set x = .Range("A2", .Range("F1000").End(xlUp))
End With
arrList = x.Value
With ComboBox1
.ColumnCount = 6
.list = arrList
.ListIndex = 0
.TextColumn = 2
End With
Related
I'm putting together a spreadsheet that should populate checkboxes in a specific column when the spreadsheet opens if the appropriate A Column/Row is not empty. It should also remove checkboxes when it finds that same A column to be empty. My VB is correctly creating the checkboxes, but I cannot figure out how to tell the code to delete the checkbox from a specific cell.
Most articles I find mention removed ALL checkboxes, but I'm looking to do it conditionally. Any guidance would be greatly appreciated.
Private Sub Workbook_Open()
'declare a variable
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
For x = 2 To 1000
If ws.Cells(x, 1) <> "" Then
Call Add_CheckBox(CInt(x))
Else
Call Delete_CheckBox(CInt(x))
End If
Next x
End Sub
Private Sub Add_CheckBox(Row As Integer)
ActiveSheet.CheckBoxes.Add(Cells(Row, "T").Left, Cells(Row, "T").Top, 72, 12.75).Select
With Selection
.Caption = ""
.Value = xlOff '
.LinkedCell = "AA" & Row
.Display3DShading = False
End With
End Sub
Private Sub Delete_CheckBox(Row As Integer)
Dim cb As CheckBox
If cb.TopLeftCell.Address = (Row, "T") Then cb.Delete
End Sub
Naming the CheckBoxes will make it easier to maintain your code.
Private Sub Workbook_Open()
Const CheckBoxPrefix As String = "Sheet1TColumnCheckBox"
'declare a variable
Dim CheckBoxName As String
Dim ws As Worksheet
Set ws = Worksheets("Sheet1")
'calculate if a cell is not blank across a range of cells with a For Loop
Dim r As Long
For r = 2 To 1000
CheckBoxName = CheckBoxPrefix & r
If Len(ws.Cells(r, 1)) > 0 Then
If Not WorksheetContainsCheckBox(CheckBoxName, ws) Then Add_CheckBox CheckBoxName, ws.Cells(r, 1), ws.Cells(r, "AA")
Else
If WorksheetContainsCheckBox(CheckBoxName, ws) Then ws.CheckBoxes(CheckBoxName).Delete
End If
Next
End Sub
Private Sub Add_CheckBox(CheckBoxName As String, Cell As Range, LinkedCell As Range)
With Cell.Worksheet.CheckBoxes.Add(Cell.Left, Cell.Top, 72, 12.75)
.Caption = ""
.Value = xlOff '
.LinkedCell = LinkedCell
.Display3DShading = False
.Name = CheckBoxName
End With
End Sub
Function WorksheetContainsCheckBox(CheckBoxName As String, ws As Worksheet)
Dim CheckBox As Object
On Error Resume Next
Set CheckBox = ws.CheckBoxes(CheckBoxName)
WorksheetContainsCheckBox = Err.Number = 0
On Error GoTo 0
End Function
Try something like this (put a checkbox "in" A1 but not C1)
Sub tester()
Debug.Print Delete_CheckBox([A1])
Debug.Print Delete_CheckBox([C1])
End Sub
'Return True if able to delete a checkbox from range `rng`
Private Function Delete_CheckBox(rng As Range) As Boolean
Dim cb As CheckBox
For Each cb In rng.Worksheet.CheckBoxes
If Not Application.Intersect(cb.TopLeftCell, rng) Is Nothing Then
Debug.Print "Deleting checkbox in " & cb.TopLeftCell.Address
cb.Delete
Delete_CheckBox = True
Exit For 'if only expecting one matched checkbox
End If
Next cb
End Function
I am trying to achieve code where multi-select ListBoxes are added if Column 4 or 5 are selected and Column 2 in the same row has the string "has options".
The Listboxes contain values from named ranges called "option1" and "option2". Current Selections are output to the respective cell in Column 4 or 5 separated by commas.
This is the code I have in "This Workbook" object. It needs to work on all sheets.
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
If Target.Cells.Count > 1 Then Exit Sub
If Target.Column = 4 And Target.OFFSET(0, -1).Value = "has options" Then
CreateOpt1PopUp Target
End If
If Target.Column = 5 And Target.OFFSET(0, -2).Value = "has options" Then
CreateOpt2PopUp Target
End If
Else
DeleteAllOpt1PopUps Target
DeleteAllOpt2PopUps Target
End If
End If
End Sub
This is the code I have in a Module. The criteria has evolved and therefore I have amended the code multiple times to the point where it no longer works.
Private opt1SelectCell As Range
Public Function Opt1Area(ByRef ws As Worksheet) As Range
Const OPT1_COL As Long = 4
Dim lastOpt1Row As Long
With ws
lastOpt1Row = .Cells(.Rows.Count, 1).End(xlUp).Row - 1
If lastOpt1Row = 0 Then
Set Opt1Area = Nothing
Else
Set Opt1Area = .Cells(2, OPT1_COL).Resize(lastOpt1Row, 1)
End If
End With
End Function
Public Sub Opt1BoxClick()
Dim opt1BoxName As String
opt1BoxName = Application.Caller
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes(opt1BoxName)
Dim opt1List As String
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.Selected(i) Then
opt1List = opt1List & opt1Box.List(i) & ","
End If
Next i
If Len(opt1List) > 0 Then
opt1List = Left$(opt1List, Len(opt1List) - 1)
End If
opt1SelectCell.Value = opt1List
End Sub
Public Function Opt1ListArea() As Range
Set Opt1ListArea = ActiveSheet.Range("option1")
End Function
Public Sub DeleteAllOpt1PopUps(ByRef selectedCell As Range)
Dim opt1Box As ListBox
For Each opt1Box In selectedCell.Parent.ListBoxes
opt1Box.Delete
Next opt1Box
End Sub
Public Sub CreateOpt1PopUp(ByRef selectedCell As Range)
Set opt1SelectCell = selectedCell
Dim Opt1PopUpCell As Range
Set Opt1PopUpCell = opt1SelectCell.OFFSET(1, 0)
DeleteAllOpt1PopUps selectedCell
'--- now create listbox
Const OPT1_POPUP_WIDTH As Double = 75
Const OPT1_POPUP_HEIGHT As Double = 110
Const OPT1_OFFSET As Double = 5#
Dim opt1Box As ListBox
Set opt1Box = ActiveSheet.ListBoxes.Add(Opt1PopUpCell.Left + OPT1_OFFSET, _
Opt1PopUpCell.Top + OPT1_OFFSET, _
OPT1_POPUP_WIDTH, _
OPT1_POPUP_HEIGHT)
With opt1Box
.ListFillRange = Opt1ListArea().Address(external:=True)
.LinkedCell = ""
.MultiSelect = xlSimple
.Display3DShading = True
.OnAction = "Module1.Opt1BoxClick"
End With
'--- is there an existing list of options selected?
Dim selectedOptions1() As String
selectedOptions1 = Split(opt1SelectCell.Value, ",")
Dim opt1 As Variant
For Each opt1 In selectedOptions1
Dim i As Long
For i = 1 To opt1Box.ListCount
If opt1Box.List(i) = opt1 Then
opt1Box.Selected(i) = True
Exit For
End If
Next i
Next opt1
End Sub
This is an example of the excel data.
How can I make this work and even improve it?
I pulled the code from a Mr. Excel post and tried to repurpose it for multiple listboxes.
I want the data entered to go across multiple rows based on different variables.
That is for it to make a row of the various combinations that are selected under the listbox.
Image link: https://imgur.com/a/cWcDwNx
I'd like the options in Screenshot 1 to return Screenshot 2, but it returns Screenshot 3.
I'd like the options in Screenshot 4 to return Screenshot 5, but it returns Screenshot 6.
Private Sub CommandButton1_Click()
Dim rng As Range
Dim i As Long
Dim A As Long
Set rng = Range("A" & Rows.Count).End(xlUp).Offset(1)
For A = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(A) = True Then
rng.Resize(, 5).Value = Array(TextBox1.Value, TextBox2.Value, TextBox3.Value, ListBox2.List(A))
Set rng = rng.Offset(1)
End If
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
rng.Resize(, 5).Value = Array(TextBox1.Value, TextBox2.Value, TextBox3.Value, ListBox1.List(i), ListBox2.List(A))
Set rng = rng.Offset(1)
End If
Next i
Next A
End Sub
Private Sub UserForm_Initialize()
With ListBox1
.List = Array("A", "B", "C")
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
End With
With ListBox2
.List = Array("Kappa", "Keepo")
.ListStyle = fmListStyleOption
.MultiSelect = fmMultiSelectMulti
End With
End Sub
Where am I going wrong, is it the Syntax or the entire approach?
How could do this for multiple listboxes, maybe even 4?
You need nested loops (untested)
Private Sub CommandButton1_Click()
Dim rng As Range, i As Long, j As Long, ar
Set rng = Range("A" & Rows.Count).End(xlUp).Offset(1).Resize(, 5)
ar = Array(TextBox1.Value,TextBox2.Value,TextBox3.Value,"","")
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
ar(3) = ListBox1.List(i)
For j = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(j) = True Then
ar(4) = ListBox2.List(j)
rng.Value = ar
Set rng = rng.Offset(1)
End If
Next
End If
Next
End Sub
I need your help moving data from a listbox to a worksheet.
This listbox contains 14 columns. How can I copy the rows from the listbox to the worksheet?
Sub Post ()
Dim arr
Dim cnt As Integer
cnt = ListBox1.ListCount
arr = ListBox1.List
With Sheets("DATABASE").ListObjects(1)
.ListRows.Add
.DataBodyRange.Cells(.ListRows.Count, 1).Resize(cnt, 14) = arr
End With
ListBox1.clear
End Sub
***************** Update 15-01-2019 17:30 **********************
i found this code but it moves 1 line down as pic below
Private Sub CommandButton2_Click()
Dim i As Long
For i = 0 To ListBox1.ListCount
For x = 1 To 14
Sheets("Database").Range("B2").End(xlDown).Offset(i + 1, x - 1) =
ListBox1.List(i, x - 1) 'ListBoxl.List(i, x)
Next x
Next i
End Sub
Pic
It is not very clear how you set the target cell, anyhow you can try this (following the logic of your sample):
Dim Trg as Range
With Sheets("DATABASE").ListObjects(1)
Set Trg = .DataBodyRange.Cells(.ListRows.Count, 1)
End With
Trg.Resize(UBound(arr, 1), UBound(arr, 2)) = arr
It is easy to paste the content of an array to a range if you can specify the top left cell and the bottom right cell of the target range in advance, so you can say
Range("B8:E16") = arr
If you only know the the top left cell and want to set the size of the target range dynamically, use .Resize like this:
Range("B8").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
NB: if the target range is smaller than the array then only that amount of data is copied, the rest is omitted.
finally i found a code that solved my problem
Private Sub CommandButton1_Click()
Dim lngItem As Long
For lngItem = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(lngItem) Then
With Sheets(1) '< qualify sheet here
.Cells(.Rows.Count, "B").End(xlUp).Offset(1).Value =
ListBox1.List(lngItem, 1)
.Cells(.Rows.Count, "C").End(xlUp).Offset(1).Value =
ListBox1.List(lngItem, 2)
End With
End If
Next lngItem
'Unload Me
End Sub
I have a worksheet with 6 activex comboboxes.
Combobox1 has 21 choiches.
Combobox2 is dependent on Combobox1, number of choices vary.
Combobox3 has 2 choices.
Combbox4 is dependent on Combobox3 and has 21 choices.
Combobox5 has 21 choiches.
Combobox6 is dependent on Combobox5, number of choices vary.
I would like to loop through combobox1 - value1 and combobox2 - value1.
Then I would like to loop through combobox3 - value 1 and combobox4 - value1.
I would like to loop through combobox5 - value1 and combobox6 - value1.
I am using vlookup to based on the linked cells of the different comboboxes. The code I have at the moment only loops through the cell values of combobox1 and combobox2. I would like to physically change the value in the combobox, from value1 to lastvalue.
Which would be Combobox1 - value1, combobox2 value1 to last value, combobox3 first value, combobox4 - value1, combobox 5, value1 and finally combobox6 - value1 to last value.
Sub Demo()
Dim Ws As Worksheet
Dim shp As Shape
Dim cb As ComboBox
Set Ws = ActiveSheet
For Each shp In Ws.Shapes
With shp
Select Case .Type
Case msoFormControl
If .FormControlType = xlDropDown Then
If .ControlFormat.Value = 0 Then
MsgBox .Name & " = "
Else
MsgBox .Name & " = " & .ControlFormat.List(.ControlFormat.Value)
End If
End If
Case msoOLEControlObject
If .OLEFormat.progID = "Forms.ComboBox.1" Then
Set cb = .OLEFormat.Object.Object
MsgBox cb.Name & " = " & cb.Value
End If
End Select
End With
Next
End Sub
The code above gives me the values of my 6 activex comboboxes.
Sub try()
Dim Ws As Worksheet
Set Ws = Worksheets("Sheet1")
Count = 0
For Each OleObj In Ws.OLEObjects
If OleObj.OLEType = xlOLEControl Then
If TypeName(OleObj.Object) = "ComboBox" Then
Count = Count + 1
End If
End If
Next OleObj
MsgBox "Number of ComboBoxes :" & Count
End Sub
This code counts the amount of comboboxes in a sheet! Maybe it can be adapted to increment each combobox?
I am thinking about something like this:
Sub Test()
Select Case Me.Form
Case "Stockholms län"
Me.Kommun1.RowSource = "Stockholms_län"
' Code for each loop where combobox1 is "Stockholm län" and Combobox2
' is a named range.
Case "Skåne län"
Me.Kommun1.RowSource = "Skåne_län"
' Code for each loop where combobox1 is "Skåne län" and Combobox2 is
' a named range.
End Select
End sub
I can manually set the values of combobox1 and combobox2.
Sub WantToLoop()
Dim län1 As String
Dim kommun1 As String
Dim län2 As String
Dim kommun2 As String
ThisWorkbook.Sheets("Test").län1 = "Skåne län"
ThisWorkbook.Sheets("Test").kommun1 = "Bjuv"
End Sub
The code above kind of works but I can't do select cases for several hundred of choices. How can I loop this?
I am getting closer but now I am setting the value of the combobox. I want to access the value of the combobox.
Sub try()
Dim i As Integer
Dim j As Integer
For i = 1 To 2
Sheets("Test").Shapes("Län" & i).OLEFormat.Object.Object = "item" & i
Sheets("Test").Shapes("Kommun" & i).OLEFormat.Object.Object = "item" & i
Next
End sub
Sub IterateComboBox()
Dim i As Long
With Sheets("Jämföra").Län1
For i = 0 To .ListCount - 1
'Debug.Print .List(i)
.Value = .List(i)
Next
End With
End Sub
This code does what I want. How can I turn this into a select case?
Sub Try2()
Dim k As Integer
Dim l As Integer
Dim m As Integer
Dim n As Integer
Sheets("Test").Län1.ListIndex = 0
For l = 0 To 25
Sheets("Test").Kommun1.ListIndex = l
Sheets("Test").Län2.ListIndex = 0
For n = 0 To 25
Sheets("Test").Kommun2.ListIndex = n
Application.ScreenUpdating = True
Sheets("Score").Select
Dim LR As Long
LR = Cells(Rows.Count, 1).End(xlUp).Row + 1
'Län1, Kommun1 OK
Cells(LR, "A").Value = Sheets("Test").Range("G5").Value
Cells(LR, "B").Value = Sheets("Test").Range("G6").Value
Next
Next
End Sub
This code loops through combobox1 value1, combobox2 all values, combobox3 value1 and combobox4 all values. How can I turn this into a case?
Or how do I turn this into a function where I can pass the values of Län1, Kommun1, Län2 and Kommun2 into the function??