I have a listbox with multiple (3 columns) selected items and I would like to move only the selected ones to another listbox, but this listbox should also contain 3 columns.
Before selecting new items, I've added the other items to the listbox1 with this code:
Private Sub UserForm_Initialize()
ListBox1.MultiSelect = 2
ListBox2.MultiSelect = 2
Dim RowsNumber As Integer
Dim RowsNumberOnly As Integer
Dim i As Integer
Dim Customers As Long
Dim customersloop As Long
Dim test As String
RowsNumber = FunctionCount.calculateRows
RowsNumberOnly = FunctionCount.calculateRowsValue
ListBox1.ColumnCount = 3
ListBox1.ColumnWidths = "50;50;50"
ListBox2.ColumnCount = 3
ListBox2.ColumnWidths = "50;50;50"
Customers = 10
i = 0
For customersloop = Customers To RowsNumber
ListBox1.AddItem
ListBox1.List(i, 0) = Sheets("Test").Range("J" & customersloop).Value
ListBox1.List(i, 1) = Sheets("Test").Range("K" & customersloop).Value
ListBox1.List(i, 2) = Sheets("Test").Range("L" & customersloop).Value
i = i + 1
Next
End Sub
After that the selected item need to be transferred to the other listbox2
This is my code:
Private Sub SelectItems_btn_Click()
Dim SelectedItems As String
Dim i As Integer
Dim ListBox2i As Integer
ListBox2i = 0
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
Me.ListBox2.Additem
Me.ListBox2.List(ListBox2i, 0) = ListBox1.List(i, 0).Value
Me.ListBox2.List(ListBox2i, 1) = ListBox1.List(i, 1).Value
Me.ListBox2.List(ListBox2i, 2) = ListBox1.List(i, 2).Value
ListBox2i = ListBox2i + 1
End If
Next
End Sub
I hope that you could help. I always get the error message that am object is missing.
Best regards
Matthias
If you want to move items from list1 to another list2 you can use the columns property from vba.
this is the solution code after I added the values to my first list1 with 3 columns.
Private Sub SelectItems_Click()
Dim i As Integer
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
ListBox2.AddItem
ListBox2.Column(0, (ListBox2.ListCount - 1)) = ListBox1.Column(0, i)
ListBox2.Column(1, (ListBox2.ListCount - 1)) = ListBox1.Column(1, i)
ListBox2.Column(2, (ListBox2.ListCount - 1)) = ListBox1.Column(2, i)
End If
Next
End Sub
Best regards
Related
I have an MultiSelect Listbox with 2 columns and 100 items. It is possible that the selected items to go on top of the listbox?
For example, this is the listbox:
Azerty 120ms
QWERTY 12,56ms
RAW 450,25ms
doWn 235,00 ms
alfa 258,7ms
etc....
If I check 'doWn and RAW' to go on top of the list like this (the order is not important):
doWn 235,00 ms
RAW 450,25ms
Azerty 120ms
QWERTY 12,56ms
alfa 258,7ms
etc....
I have done it like this.
The code is in a textbox change status.
Add Items of listBox in an array.
Loop through list box to see which item is selected.
Add selection numbers in a string, Strings in an array of selected_items and not_selected_items.
Loop array to rearrange the items based on selection and original array
code:
Private Sub TextBox2_Change()
Dim arr()
Dim arrYes() As String
Dim arrNo() As String
Dim i As Long, j As Long
Dim yes As String, no As String
On Error GoTo nirvana
arr = Me.ListBox2.List
For i = 0 To Me.ListBox2.ListCount - 1
If Me.ListBox2.selected(i) = True Then
yes = i & "," & yes
Else
no = i & "," & no
End If
Next
arrYes = Split(StrReverse(Left(yes, Len(yes) - 1)), ",")
arrNo = Split(StrReverse(Left(no, Len(no) - 1)), ",")
i = -1
For j = 0 To UBound(arrYes())
i = i + 1
With Me.ListBox2
.List(i, 0) = arr(arrYes(j), 0)
.List(i, 1) = arr(arrYes(j), 1)
.selected(i) = True
End With
Next j
For j = 0 To UBound(arrNo())
i = i + 1
With Me.ListBox2
.List(i, 0) = arr(arrNo(j), 0)
.List(i, 1) = arr(arrNo(j), 1)
.selected(i) = False
End With
Next j
nirvana:
Exit Sub
End Sub
I have a code which display the text of the cell underneath it. However, it seems that the Combobox just refuse to display the correct text. As you can see in the screenshot
The Text property is different from the displaying text. It's the previous value.
ScreenUpdating is True
The combobox is enabled
There is only 1 combobox, no other objects/shapes/buttons/forms. And a single table in this sheet.
Other information:
Problematic ComboBox is in sheet LinhKien, other comboboxes work fine. I don't know how to upload file here, so it's a 7 days link valid begin from 20220712 (YYYYMMDD)
The combobox is hidden when user is not selecting column 1 or select more than 1 cell. It becomes visible when a cell in column 1 is selected.
I have 2 other sheets with Comboboxes behave the exact same way (hidden when not in certain column, text comes from underneath cell) but they don't have this problem.
If the code is of relevant, here it is.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
DoEvents
If Selection.Count > 1 Then Exit Sub
If Application.CutCopyMode Then
searchBoxAccessories.Visible = False
Exit Sub
End If
If searchBoxAccessories Is Nothing Then
Set searchBoxAccessories = ActiveSheet.OLEObjects("SearchCombBoxAccessories")
End If
If Target.Column = 1 And Target.Row > 3 Then
Dim isect As Range
Set isect = Application.Intersect(Target, ListObjects(1).Range)
If isect Is Nothing Then GoTo DoNothing
isInitializingComboBox = True
GetSearchAccessoriesData
searchBoxAccessories.Activate
isInitializingComboBox = True 'This prevent "_Change" fires up when something changes
searchBoxAccessories.Top = Target.Top
searchBoxAccessories.Left = Target.Left
searchBoxAccessories.Width = Target.Width + 15
searchBoxAccessories.Height = Target.Height + 2
Application.EnableEvents = False 'Another attemp to prevent "_Change" fires up when something changes
searchBoxAccessories.Object.text = Target.text
Application.EnableEvents = True
searchBoxAccessories.Object.SelStart = 0
searchBoxAccessories.Object.SelLength = Len(Target.text)
searchBoxAccessories.Visible = True
isInitializingComboBox = False 'Screenshot is taken here
Set workingCell = Target
Else
DoNothing:
If searchBoxAccessories Is Nothing Then
Set searchBoxAccessories = ActiveSheet.OLEObjects("SearchCombBoxAccessories")
End If
If searchBoxAccessories.Visible Then searchBoxAccessories.Visible = False
End If
End Sub
_____________________
Public Sub GetSearchAccessoriesData()
Dim col2Get As String: col2Get = "3;4;5;6"
Dim dataSourceRg As Range: Set dataSourceRg = GetTableRange("PhuKienTbl")
If Not IsEmptyArray(searchAccessoriesArr) Then Erase searchAccessoriesArr
searchAccessoriesArr = GetSearchData(col2Get, dataSourceRg, Sheet22.SearchCombBoxAccessories)
End Sub
_____________________
Public Function GetSearchData(col2Get As String, dataSourceRg As Range, searchComboBox As ComboBox, _
Optional filterMat As String = "") As Variant
Dim filterStr As String: filterStr = IIf(filterMat = "", ";", "1;" & filterMat)
Dim colVisible As Integer: colVisible = 1
Dim colsWidth As String: colsWidth = "200"
Dim isHeader As Boolean
Dim colCount As Integer: colCount = Len(col2Get) - Len(Replace(col2Get, ";", "")) + 1
GetSearchData = GetArrFromRange(dataSourceRg, col2Get, False, filterStr)
With searchComboBox
.ColumnCount = colVisible
.ColumnWidths = colsWidth
.ColumnHeads = False
End With
Set dataSourceRg = Nothing
End Function
_____________________
Public Function GetArrFromRange(rg As Range, cols2GetStr As String, isHeader As Boolean, Optional colCriFilterStr As String = ";") As Variant
Dim col2Get As Variant: col2Get = Split(cols2GetStr, ";")
Dim arrRowsCount As Integer
Dim arrColsCount As Integer: arrColsCount = UBound(col2Get) + 1
Dim resultArr() As Variant
Dim iRow As Integer
Dim iCol As Integer
Dim criCol As Integer
If Len(colCriFilterStr) = 1 Then
criCol = 0
Else: criCol = CInt(Left(colCriFilterStr, InStr(colCriFilterStr, ";") - 1))
End If
Dim criStr As String: criStr = IIf(isHeader, "", Mid(colCriFilterStr, InStr(colCriFilterStr, ";") + 1))
If isHeader Then
arrRowsCount = 1
Else
If criCol <> 0 Then
arrRowsCount = WorksheetFunction.CountIf(rg.Columns(criCol), criStr)
Else
arrRowsCount = rg.Rows.Count
End If
End If
If arrRowsCount = 0 Then GoTo EndOfFunction
ReDim resultArr(1 To arrRowsCount, 1 To arrColsCount)
Dim wkCell As Range
Dim arrRow As Integer: arrRow = 1
For iRow = IIf(isHeader, 1, 2) To IIf(isHeader, 1, rg.Rows.Count)
If criStr = "" Then
For iCol = 1 To arrColsCount
resultArr(arrRow, iCol) = rg.Cells(iRow, CDbl(col2Get(iCol - 1))).Value
Next iCol
arrRow = arrRow + 1
Else
If rg.Cells(iRow, criCol).Value = criStr Then
For iCol = 1 To arrColsCount
resultArr(arrRow, iCol) = rg.Cells(iRow, CDbl(col2Get(iCol - 1))).Value
Next iCol
arrRow = arrRow + 1
End If
End If
Next iRow
EndOfFunction:
GetArrFromRange = resultArr
Erase resultArr
End Function
After weeks of frustration, I am please to announce that I found out the cause. It was the Freeze Panes that affects the display of combobox. Particularly, ComboBox placed in freezed column is not refreshed as frequently as in other cell. In that area, combobox almost act as it's disabled (visually). No text changes update even when you type, no selection/highlighting. I changed to only freeze upper rows and the combobox works just as expected. That's why my other comboboxes in other sheets behaved correctly.
I suspect that Excel tries to save resources by making the freezed part not as responsive. That behavior override Application.ScreenUpdating and not exposed to user.
Since this "feature" could be version specific, my system is Win 10 pro, Excel 16 pro plus.
I have an event handler Sub that listens for a response message from the Bloomberg API, and stores it in a Dd array.
According to MSDN, event handlers must be subs, but I would like to do further analysis on the data in my main method.
How can I reference the array created in the event handler, such that I can continue to process the data?
Event handler:
Private Sub session_ProcessEvent(ByVal obj As Object)
On Error GoTo errHandler
Dim eventObj As blpapicomLib2.Event
Set eventObj = obj
If Application.Ready Then
If eventObj.EventType = PARTIAL_RESPONSE Or eventObj.EventType = RESPONSE Then
Dim it As blpapicomLib2.MessageIterator
Set it = eventObj.CreateMessageIterator()
Dim numResponse As Integer
numResponse = 0
Dim data() As Variant
Do While it.Next()
numResponse = numResponse + 1
Dim msg As Message
Set msg = it.Message
Dim securityData As Element
Dim securityName As Element
Dim fieldData As Element
Set securityData = msg.GetElement("securityData")
Set securityName = securityData.GetElement("security")
Set fieldData = securityData.GetElement("fieldData")
Sheet1.Cells(currentRow, 4).Value = securityName.Value
Dim numDates As Integer
Dim numFields As Integer
numDates = fieldData.NumValues
numFields = fieldData.GetValue(0).NumElements
ReDim data(numDates, numFields, numResponse)
Dim b As Integer
For b = 0 To numDates - 1
Dim fields As blpapicomLib2.Element
Set fields = fieldData.GetValue(b)
Dim a As Integer
For a = 0 To numFields - 1
Dim field As Element
Set field = fields.GetElement(a)
data(b, a, numResponse) = field.Value
Sheet1.Cells(currentRow, a + 5).Value = data(b, a, numResponse)
Next
currentRow = currentRow + 1
Next b
Loop
' skip a row for next security
currentRow = currentRow + 1
End If
End If
Exit Sub
errHandler:
MsgBox Err.Description
End Sub
...and the sub I would like to process the array in here...
Public Sub RefDataExample()
' Calculate the number of securities and fields
Dim numSecurity As Integer
Dim numFields As Integer
numSecurity = 0
numFields = 0
' clear data area
Range("D4", "H60000").Clear
Do While Cells(numSecurity + 4, 1).Value <> ""
numSecurity = numSecurity + 1
Loop
Do While Cells(numFields + 4, 2).Value <> ""
numFields = numFields + 1
Loop
Dim sSecurity() As String
Dim sFields() As Variant
ReDim sSecurity(0 To numSecurity - 1) As String
ReDim sFields(0 To numFields - 1) As Variant
Dim i As Integer
For i = 0 To numSecurity - 1
sSecurity(i) = Cells(i + 4, 1).Value
Next i
For i = 0 To numFields - 1
sFields(i) = Cells(i + 4, 2).Value
Next i
bbControl.MakeRequest sSecurity, sFields
'Process response array here
End Sub
Remove
Dim data() As Variant
from within all the subs it currently appears in (like from within your session_ProcessEvent())
and place
Public data As Variant
at the top of the module containing your sub (actually you can place it at the top of any module you like)
and you'll have ”data” visible from all subs/functions of your project
I'm trying to add a list of names from another worksheet that has duplicates. On the listbox, I want to have unique names, instead of duplicates. The following code is not sorting them for duplicates, it errors out. Any help is appreciated.
Dim intCount As Integer
Dim rngData As Range
Dim strID As String
Dim rngCell As Range
dim ctrlListNames as MSForms.ListBox
Set rngData = Application.ThisWorkbook.Worksheets("Names").Range("A").CurrentRegion
'declare header of strID and sort it
strID = "Salesperson"
rngData.Sort key1:=strID, Header:=xlYes
'Loop to add the salesperson name and to make sure no duplicates are added
For Each rngCell In rngData.Columns(2).Cells
If rngCell.Value <> strID Then
ctrlListNames.AddItem rngCell.Value
strID = rngCell.Value
End If
Next rngCell
Way 1
Use this to remove the duplicates
Sub Sample()
RemovelstDuplicates ctrlListNames
End Sub
Public Sub RemovelstDuplicates(lst As msforms.ListBox)
Dim i As Long, j As Long
With lst
For i = 0 To .ListCount - 1
For j = .ListCount - 1 To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
Way 2
Create a unique collection and then add it to the listbox
Dim Col As New Collection, itm As Variant
For Each rngCell In rngData.Columns(2).Cells
On Error Resume Next
Col.Add rngCell.Value, CStr(rngCell.Value)
On Error GoTo 0
Next rngCell
For Each itm In Col
ctrlListNames.AddItem itm
Next itm
Private Sub Workbook_Open()
Dim ctrlListNames As MSForms.ListBox
Dim i As Long
Dim j As Long
ctrlListNames.List = Application.ThisWorkbook.Worksheets("Names").Range("Salesperson").Value
With ctrlListNames
For i = 0 To .ListCount - 1
For j = .ListCount To (i + 1) Step -1
If .List(j) = .List(i) Then
.RemoveItem j
End If
Next
Next
End With
End Sub
And it says invalid property array index.
It says invalid property array index because the list gets shortened after the removal of entries. if we use FOR, the end value is static, therefore, we need to use DO while loop. Use the following code to remove duplicates.
Count = ListBox1.ListCount - 1
i = 0
j = 0
Do While i <= Count
j = i + 1
Do While j <= Count
If ListBox1.List(i) = ListBox1.List(j) Then
ListBox1.RemoveItem (j)
Count = ListBox1.ListCount - 1 'Need to update list count after each removal.
End If
j = j + 1
Loop
i = i + 1
Loop
My end result is to output the names in column A to column B in random order.
I have been researching but cant seem to find what I need.
So far I can kinda of randomise the numbers but its still giving me repeated numbers + the heading (A1).
I need it to skip A1 because this is the heading\title of the column and start at A2.
I assume once that is working correctly I add the randomNumber to a random name to Worksheets("Master Sheet").Cells(randomNumber, "B").Value ...something like that...?
OR if there is a better way of doing this let me know.
Sub Meow()
Dim CountedRows As Integer
Dim x As Integer
Dim i As Integer
Dim PreviousCell As Integer
Dim randomNumber As Integer
i = 1
PreviousCell = 0
CountedRows = Worksheets("Master Sheet").Range("A" & Rows.Count).End(xlUp).Row
If CountedRows < 2 Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
Do Until i = CountedRows
randomNumber = Int((Rnd * (CountedRows - 1)) + 1) + 1
If Not PreviousCell = randomNumber Then
Debug.Print randomNumber
i = i + 1
End If
PreviousCell = randomNumber
Loop
Debug.Print "EOF"
End Sub
Here's a quick hack...
Sub Meow()
'On Error GoTo err_error
Dim CountedRows As Integer
Dim x As Integer
Dim i As Integer
Dim PreviousCell As Integer
Dim randomNumber As Integer
Dim nums() As Integer
PreviousCell = 0
CountedRows = Worksheets("Master Sheet").Range("A" & Rows.Count).End(xlUp).Row
ReDim nums(CountedRows - 1)
If CountedRows < 2 Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
For i = 1 To CountedRows
rand:
randomNumber = randomNumbers(1, CountedRows, nums)
nums(i - 1) = randomNumber
Worksheets("Master Sheet").Range("B" & randomNumber) = Range("A" & i)
Next i
Exit Sub
err_error:
Debug.Print Err.Description
End Sub
Public Function randomNumbers(lb As Integer, ub As Integer, used As Variant) As Integer
Dim r As Integer
r = Int((ub - lb + 1) * Rnd + 1)
For Each j In used
If j = r Then
r = randomNumbers(lb, ub, used)
Else
randomNumbers = r
End If
Next
End Function
I've managed something similar previously using two collections.
Fill one collection with the original data and leave the other collection empty. Then keep randomly picking an index in the first collection, adding the value at that index to the second collection and delete the value from the original collection. Set that to loop until the first collection is empty and the second collection will be full of a randomly sorted set of unique values from your starting list.
***Edit: I've thought about it again and you don't really need the second collection. You can pop a random value from the first collection and write it directly to the worksheet, incrementing the row each time:
Sub Meow()
Dim lst As New Collection
Dim rndLst As New Collection
Dim startRow As Integer
Dim endRow As Integer
Dim No_People_Error As Integer
startRow = 2
endRow = Worksheets("Master Sheet").Cells(startRow, 1).End(xlDown).Row
If Cells(startRow, 1).Value = "" Then
' If its only the heading then quit and display a messagebox
No_People_Error = MsgBox("No People entered or found, in column 'A' of Sheetname 'Master Sheet'", vbInformation, "Pavle Says No!")
Exit Sub
End If
' Fill a collection with the original list
Dim i As Integer
For i = startRow To endRow
lst.Add Cells(i, 1).Value
Next i
' Create a randomized list collection
' Use i as a row counter
Dim rowCounter As Integer
rowCounter = startRow
Dim index As Integer
Do While lst.Count > 0
'Find a random index in the original collection
index = Int((lst.Count - 1 + 1) * Rnd + 1)
'Place the value in the worksheet
Cells(rowCounter, 2).Value = lst(index)
'Remove the value from the list
lst.Remove (index)
'Increment row counter
rowCounter = rowCounter + 1
Loop
End Sub
P.S. I hope there's an excellent story behind naming your sub Meow() :P