I am trying to create a listbox with the column headers of my data to use that as an input from the user on which columns the user wants displayed in the final result. So far I've been able to divide the listbox into two columns and populate the relevant data in it, but on selecting the items, it is selecting the complete row and not individual items.
Can you please let me know how can I select individual items from a multicolumn listbox.
Here's the code :
Private Sub ListBox1_Enter()
Dim firstrow As Range
Dim c_no As Integer
Dim Arr() As String
Dim i As Integer
Dim j As Integer
Set firstrow = ThisWorkbook.Sheets("Tag Dump").Range("A1:AR1")
With firstrow
c = .Cells.Count
End With
Application.ScreenUpdating = False
ReDim Preserve Arr(c, 2)
'If WorksheetFunction.IsEven(c) = True Then
For i = 1 To c / 2
Arr(i, 1) = Sheets("Tag Dump").Cells(1, i).Value
Arr(i, 2) = Sheets("Tag Dump").Cells(1, i + (c / 2)).Value
'ElseIf WorksheetFunction.IsEven(c) = False Then
'End If
With ListBox1
.ColumnCount = 2
.Additem
.List(i - 1, 0) = Arr(i, 1)
.List(i - 1, 1) = Arr(i, 2)
End With
Next
With ListBox1
.ListStyle = fmListStyleOption
.Font = "Arial"
.MultiSelect = fmMultiSelectExtended
End With
Application.ScreenUpdating = True
End Sub
Here's an image of the result I'm getting:
Listbox selection
Thanks in advance.
Related
I have workbook with one sheet and 80k lines as shown below. same Client may come up 100 times in sheet1.i need to look for value under ddindex value "1" and value under tier value "2", if these condition match then pick client name and put in new sheet ( sheet2) with their value from column data size. If same client comes again using above condition while going row by row in sheet1 then add( sum it with previous value) data size in second sheet ( sheet2). And also get latest created date and expiry date for same client in second sheet. any idea how to achieve this using VBA ??
so far i come up below code
Option Explicit
Sub find()
Dim i As Long
Dim sheets As Variant
Dim sheet As Variant
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
Set ws = ThisWorkbook.sheets("Sheet2")
For i = 2 To ActiveSheet.sheets("sheet1").Range("A2").End(xlDown).Row
If Cells(i, 4).Value = 1 And Cells(i, 6).Value = 2 Then
ws.Range(1 & i).Value = Cells(i, 1).Value
ws.Range("A" & i).Value = Cells(i, 1).Value
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Try something like this:
Sub Summarize()
Dim i As Long, ws1 As Worksheet, ws2 As Worksheet, data, m, client
Dim dict As Object, dataOut, rw As Long
Set dict = CreateObject("scripting.dictionary") 'for tracking unique client id's
Set ws1 = ThisWorkbook.sheets("Sheet1")
Set ws2 = ThisWorkbook.sheets("Sheet2")
data = ws1.Range("A2:F" & ws1.Cells(Rows.Count, 1).End(xlUp).Row).Value 'data to array
ReDim dataOut(1 To UBound(data, 1), 1 To UBound(data, 2)) 'size output array
rw = 0
For i = 1 To UBound(data, 1) 'loop over rows in the array
If data(i, 5) = 1 And data(i, 6) = 2 Then 'processing this row?
client = data(i, 1)
If Not dict.exists(client) Then 'first time for this client?
rw = rw + 1 'increment "row" counter
dict.Add client, rw 'store position in dictionary
dataOut(rw, 1) = client 'add the client id
End If
rw = dict(client) 'find the array "row" to update
If data(i, 2) > dataOut(rw, 2) Then
dataOut(rw, 2) = data(i, 2)
dataOut(rw, 3) = data(i, 3)
End If
dataOut(rw, 4) = dataOut(rw, 4) + data(i, 4)
dataOut(rw, 5) = data(i, 5)
dataOut(rw, 6) = data(i, 6)
End If
Next
'drop the summarized data on the worksheet
If rw > 0 Then ws2.Range("A2").Resize(rw, UBound(data, 2)).Value = dataOut
End Sub
On the left is the hypothetical database. On the right is the result I would like to obtain.
I would like to print all of the items of type B, as well as the sum and the count.
I'm stuck and I'm not able to go ahead. Could you please help me out? Thanks.
Private Sub CommandButton1_Click()
Dim dicDistincts As Scripting.Dictionary, _
dicDuplicates As Scripting.Dictionary
Set dicDistincts = New Scripting.Dictionary
Set dicDuplicates = New Scripting.Dictionary
Dim i As Integer
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
If Not dicDistincts.Exists(Cells(i, 2).Value) Then
dicDistincts.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
Else
dicDuplicates.Add Key:=Cells(i, 2).Value, Item:=Cells(i, 2).Value
End If
End If
Next i
For i = 0 To dicDuplicates.Count - 1
Cells(i + 1, 9).Value = WorksheetFunction.CountIfs(Range("a2:a10"), "B", Range("b2:b10"), dicDistincts.keys(i))
Next i
End Sub
EDIT: I tried with countifs but it return 0 for banana, apple and strawberry
EDIT 2: I corrected the countifs. Now it works.
If you must use dictionaries then you could do this with a single dictionary, storing the counts and quantities as array as the values in the dictionary.
Private Sub CommandButton1_Click()
Dim dic As Scripting.Dictionary
Dim arrData()
Dim i As Long
Dim ky As Variant
Set dic = New Dictionary
For i = 2 To 10
If Cells(i, 1).Value = "B" Then
ky = Cells(i, 2).Value
If Not dic.Exists(ky) Then
arrData = Array(1, Cells(i, 3).Value)
Else
arrData = dic(ky)
arrData = Array(arrData(0) + 1, arrData(1) + Cells(i, 3).Value)
End If
dic(ky) = arrData
End If
Next i
Range("A1:C1").Copy Range("E1:G1")
For i = 0 To dic.Count - 1
Range("E" & i + 2) = dic.Keys(i)
Range("F" & i + 2).Resize(, 2) = dic.Items(i)
Next i
End Sub
Unique Sum and Unique Count with Double Dictionary
Option Explicit
Private Sub CommandButton1_Click()
Dim rg As Range
With Range("A1").CurrentRegion
Set rg = .Resize(.Rows.Count - 1).Offset(1)
End With
Dim Data As Variant: Data = rg.Value
Dim cDict As Object: Set cDict = CreateObject("Scripting.Dictionary")
Dim sDict As Object: Set sDict = CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data, 1)
If Data(i, 1) = "B" Then
cDict(Data(i, 2)) = cDict(Data(i, 2)) + 1 ' Count
sDict(Data(i, 2)) = sDict(Data(i, 2)) + Data(i, 3) ' Sum
End If
Next i
ReDim Data(1 To cDict.Count, 1 To 3)
i = 0
Dim Key As Variant
For Each Key In cDict.Keys
i = i + 1
Data(i, 1) = Key
Data(i, 2) = sDict(Key)
Data(i, 3) = cDict(Key)
Next Key
With Range("E2").Resize(, 3)
.Resize(i).Value = Data
.Resize(.Worksheet.Rows.Count - .Row - i + 1).Offset(i).ClearContents
End With
End Sub
This should work it uses loops through all bs and addes them if to the other list
Sub countBs()
Dim Bs As Range 'list of the line of all Bs
Dim B As Range 'each indiviual b in the B list
Dim Item As Range 'each indivual item
Dim adder As Range 'resturns nothing if b not fond in times
Set Bs = Range("a2", Range("a2").End(xlDown)) 'you can also change this ofcourse to a specifici range or user selected
For Each B In Bs
If B = "B" Then
Set adder = Range("g2", Range("g2").End(xlDown)).Find(B.Offset(0, 1))
If adder Is Nothing Then
If Range("g2") = "" Then
Set Item = Range("g2")
Else
Set Item = Range("g1").End(xlDown).Offset(1, 0)
End If
Item.Resize(1, 2).Value = B.Offset(0, 1).Resize(1, 2).Value
Item.Offset(0, 2) = 1
Else
adder.Offset(0, 1).Value = adder.Offset(0, 1).Value + B.Offset(0, 2).Value
adder.Offset(0, 2).Value = adder.Offset(0, 2).Value + 1
End If
End If
Next B
End Sub
I have a userform with a listbox that displays data from a worksheet. I am wanting to get that data to display in the listbox by current date and time. So when a user enters new data he/she sees the most current lines of data. This is to help the user so they don't enter duplicate information.
I am hoping this can be accomplished programmatically because in the near future this form will be linked to a database not a worksheet.
Here is the code to populate my listbox:
Private Sub UserForm_Initialize() 'Sets variables when the userform initializes
Call MakeFormResizeable(Me)
Me.tbDate.Value = Format(Now(), "mm/dd/yyyy hh:mm")
With ListBox1
.RowSource = "Table1!A3:T100"
.ColumnCount = 20
.ColumnHeads = True
End With
End Sub
And the code to reload my listbox when the save button is clicked by calling "RefreshListbox" :
Private Sub RefreshListbox()
With ListBox1
.RowSource = "Table1!A3:T100"
.ColumnCount = 20
.ColumnHeads = True
End With
End Sub
Screen shot of my userform:
UserForm Screen Shot
Referred to Date Array Sort and
Populating listbox from array
Public declaration of an array variable in a module
Public Dtarr(1 To 8) As Date
One can redim the array size in a macro to resize it to the table size.
Following is the dates table
Added following procedure in a module to sort a date array.
Sub SortAr(arr() As Date)
Dim Temp As Date
Dim i As Long, j As Long
For j = 2 To UBound(arr)
Temp = arr(j)
For i = j - 1 To 1 Step -1
If (arr(i) >= Temp) Then GoTo 10
' ">" sorts in descending order.
' "<" sorts in ascending order.
arr(i + 1) = arr(i)
Next i
i = 0
10: arr(i + 1) = Temp
Next j
End Sub
Added following procedure to the userform
Private Sub UserForm_Initialize()
Dim Sh As Worksheet
Set Sh = ThisWorkbook.Worksheets("Sheet2")
For i = 1 To 8
Dtarr(i) = Sh.Range("A" & i + 3).Value
Next
SortAr Dtarr
ListBox1.List = Dtarr
End Sub
So, the output is the descending order sorted listbox. The user can always see the latest record time at the top.
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Editing answer as per your comment below
XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Following is the sample data in A1:T13.
Following is userform code. You can specify the data range (arrData) in the userform code.
Private Sub UserForm_Initialize()
Set Sh = ThisWorkbook.Worksheets("Sheet1")
Set AllData = Sh.Range("A1").CurrentRegion
x = AllData.Rows.Count - 1: y = AllData.Columns.Count
Set ListData = AllData.Offset(1, 0).Resize(x, y)
ReDim Dtarr(1 To x, 1 To y)
Dtarr = ListData.Value
Sort2DArr Dtarr, 2 'Second column as you need to sort on Column B
With ListBox1
.List = Dtarr
.ColumnCount = y
.ColumnWidths = "25;100;25;25;25;25;25;25;25;25;25;25;25;25;25;25;25;25;25;25"
End With
End Sub
Following is Module1 code to sort the Dtarr. Please note Public Dtarr() in the code
Option Base 1
Public Sh As Worksheet
Public AllData As Range
Public ListData As Range
Public x As Long
Public y As Long
Public Dtarr()
Sub Sort2DArr(arr(), srtCol As Long)
Dim temp As Date, temparr, srtColArr, temp2 As String
Dim i As Long, j As Long
ReDim temparr(x)
srtColArr = WorksheetFunction.Index(arr, 0, srtCol)
For i = 1 To x
temparr(i) = Join(Application.Index(arr, i, 0), "~")
Next
temparr = Application.Transpose(temparr)
For j = 2 To x
temp = srtColArr(j, 1)
temp2 = temparr(j, 1)
For i = j - 1 To 1 Step -1
If (srtColArr(i, 1) >= temp) Then GoTo 10
' ">" sorts in descending order.
' "<" sorts in ascending order.
srtColArr(i + 1, 1) = srtColArr(i, 1)
temparr(i + 1, 1) = temparr(i, 1)
Next i
i = 0
10: srtColArr(i + 1, 1) = temp
temparr(i + 1, 1) = temp2
Next j
ReDim Dtarr(1 To x + 1, 1 To y)
For i = 1 To y
Dtarr(1, i) = AllData(1, i).Value
Next
For i = 2 To x + 1
tempRow = Split(temparr(i - 1, 1), "~")
For j = 1 To y
Dtarr(i, j) = tempRow(j - 1)
Next
Next
End Sub
So, the output is the descending order sorted listbox. The user can always see the latest record time at the top.
I have a userform with multiple checkboxes and listboxes, where each checkbox controls the values of one listbox each.
After clicking on 'Next' the userform inputs the selected values of each listbox on the Excel sheet. I am able to achieve this only for one pair of checkbox and listbox at a time. But I want the results of each shortlisted items one after the other.
Private Sub cmdFDB_Next_Click()
Dim ColCount As Integer, lastrow As Integer
Dim lastrow1 As Integer
Dim Data As Integer
Dim i As Integer
lastrow = Worksheets("Model Portfolio").Cells(Rows.Count, 2).End(xlUp).Row
With Worksheets("Model Portfolio").Cells(lastrow, 2)
.Offset(2, 0).Value = "Fixed Deposits and Bonds"
.Offset(2, 0).Font.Bold = True
.Offset(2, 0).Font.Size = 12
For i = 2 To lastrow
If Me.chkGB.Value = True Then
.Offset(3, 0).Value = "Government Bonds"
.Offset(3, 0).Font.Bold = True
.Offset(3, 2).Value = Format(Me.txtGB.Value, "Currency")
lastrow1 = lastrow + 4
ColCount = 2
With Me.lbxGB
'loop through each listbox item to see if they are selected
For Data = 0 To .ListCount - 1
If .Selected(Data) = True Then
Cells(lastrow1, ColCount).Value = .List(Data)
lastrow1 = lastrow1 + 1
End If
Next Data
End With
End If
If Me.chkCFD.Value = True Then
.Offset(3, 0).Value = "Corporate Fixed Deposits"
.Offset(3, 0).Font.Bold = True
.Offset(3, 2).Value = Format(Me.txtCFD.Value, "Currency")
lastrow1 = lastrow + 4
ColCount = 2
With Me.lbxCFD
'loop through each listbox item to see if they are selected
For Data = 0 To .ListCount - 1
If .Selected(Data) = True Then
Cells(lastrow1, ColCount).Value = .List(Data)
lastrow1 = lastrow1 + 1
End If
Next Data
End With
End If
If Me.chkTSB.Value = True Then
.Offset(3, 0).Value = "Tax Saving Bonds"
.Offset(3, 0).Font.Bold = True
.Offset(3, 2).Value = Format(Me.txtTSB.Value, "Currency")
lastrow1 = lastrow + 4
ColCount = 2
With Me.lbxTSB
'loop through each listbox item to see if they are selected
For Data = 0 To .ListCount - 1
If .Selected(Data) = True Then
Cells(lastrow1, ColCount).Value = .List(Data)
lastrow1 = lastrow1 + 1
End If
Next Data
End With
End If
Next i
End With
With MultiPage1
.Value = (.Value + 1) Mod (.Pages.Count)
End With
End Sub
Extract selected listbox items to sheet
As you aren't consequent in your row numbering (never changing lastrow mixed with additional offsets and increments), you are loosing track of the actual row numbers.
It's also better practice to use a Sub procedure (here: WriteItems) for repetitive calls and to redefine your lastrow (here: start row) each time. Furthermore I demonstrate how to extract a whole listbox "row" using the Application.Index() function.
Further hint: Instead of direct formatting, consider to use conditional formatting (CF) as you needn't clear old formats in deleted cells (sure you find a lot of examples at SO :-)
BTW I'd prefer to avoid control names containing an underscore "_" as this has some relevance in class implementations.
Main event
Private Sub cmdFDB_Next_Click()
'[0] Define data sheet
Const SHEETNAME As String = "Model Portfolio"
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(SHEETNAME)
'[1] Define abbreviations to identify securities controls
Dim Abbreviations, abbr
Abbreviations = Array("", "GB", "CFD", "TSB") ' first item is EMPTY!
'[2] write data for each security type
Dim OKAY As Boolean
For Each abbr In Abbreviations
'[2a] check
If abbr = vbNullString Then ' Main Title
OKAY = True
ElseIf Me.Controls("chk" & abbr) Then ' individual security checked
OKAY = True
Else
OKAY = False
End If
'==================================
'[2b] write selected data in blocks
'----------------------------------
If OKAY Then WriteItems abbr, ws ' call sub procedure
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Next
End Sub
Sub procedure WriteItems
Private Sub WriteItems(ByVal abbrev As String, ws As Worksheet)
'Purpose: write caption and selected listbox items to sheet
'Note: called by cmdFDB_Next_Click()
Const EMPTYROWS As Long = 1 ' << change to needed space
Const LBXPREFIX As String = "lbx" ' << change to individual checkbox prefix
Const TITLE As String = "Fixed Deposits and Bonds"
With ws
'[0] Define new startrow
Dim StartRow As Long
StartRow = .Cells(Rows.Count, 2).End(xlUp).Row + EMPTYROWS + 1
'[1] Write caption
ws.Cells(StartRow, 2) = getTitle(abbrev) ' function call, see below
If abbrev = vbNullString Then Exit Sub ' 1st array term writes main caption only
'other stuff (e.g. formatting of title above)
'...
'[2] Write data to worksheet
With Me.Controls(LBXPREFIX & abbrev)
Dim i As Long, ii As Long, temp As Variant
For i = 1 To .ListCount
If .Selected(i - 1) = True Then
ii = ii + 1
ws.Cells(StartRow + ii, .ColumnCount).Resize(1, 2).Value = Application.Index(.List, i, 0)
End If
Next i
End With
End With
End Sub
Further note: The Application.Index function allows to get a whole listbox "row" by passing zero (..,0) as second function argument.
Helper function GetTitle()
Function getTitle(ByVal abbrev As String) As String
'Purpose: return full name/caption of security abbreviation
Select Case UCase(abbrev)
Case vbNullString
getTitle = "Fixed Deposits and Bonds"
Case "GB": getTitle = "Government Bonds"
Case "CFD": getTitle = "Corporate Fixed Deposits"
Case "TSB": getTitle = "Tax Saving Bonds"
Case Else: getTitle = "All Other"
End Select
End Function
At the moment I'm working with making a userform with 40 combobox's all which have the same list. My problem is filling all those combobox's is making the userform.show slow. The list that gets populated in those combobox's is a very long list (46542 rows and list length can vary) the list is with 3 columns.
I have been fooling around with CONCATENATE the whole list but that doesn't make much of a change. Also because I need to have the value when selected in the combobox to be CONCATENATE with all 3 columns in the combobox etc. when selecting row no. 1 in the combobox instead of writing only column 1 in the comboxbox textfield it will return all 3 columns so that means I'm actually having 4 columns where the first is CONCATENATE and hidden in the dropdown.
So my question is, is there a way to do the process more light?
So here is the code:
Private Sub UserForm_Initialize()
Set tsheet = ThisWorkbook.Sheets("Players")
Dim v As Variant, i As Long
v = tsheet.Range("A2:l" & Worksheets("Players").Cells(Rows.Count,
1).End(xlUp).Row).Value
With Me.ComboBox1
.RowSource = ""
.ColumnCount = 4
.BoundColumn = 2
.ColumnWidths = "1;50;50;50" 'Hide first column in dropdown
For i = LBound(v) To UBound(v)
.AddItem v(i, 1) & " " & v(i, 2) & " " & v(i, 3)
.List(.ListCount - 1, 1) = v(i, 1)
.List(.ListCount - 1, 2) = v(i, 2)
.List(.ListCount - 1, 3) = v(i, 3)
Next i
End With
With Me.ComboBox2
.RowSource = ""
.ColumnCount = 4
.BoundColumn = 2
.ColumnWidths = "1;50;50;50" 'Hide first column in dropdown
For i = LBound(v) To UBound(v)
.AddItem v(i, 1) & " " & v(i, 2) & " " & v(i, 3)
.List(.ListCount - 1, 1) = v(i, 1)
.List(.ListCount - 1, 2) = v(i, 2)
.List(.ListCount - 1, 3) = v(i, 3)
Next i
End With
This code goes on until it hit combox40
My old code was working pretty fast but it didn't have the column that was concatenated
ComboBox3.ColumnWidths = "50;50;50" 'COLUMN WITH OF LISTBOX
ComboBox3.ColumnCount = 3
'COLUMN NUMBER OF LISTBOX
ComboBox3.List = tsheet.Range("A2:l" &
Worksheets("Players").Cells(Rows.Count, 1).End(xlUp).Row).Value
Instead of
ComboBox3.List = tsheet.Range("A2:l" &
Worksheets("Players").Cells(Rows.Count, 1).End(xlUp).Row).Value
use something like this (declare Arr as Variant):-
Arr = tsheet.Range("A2:l" &
Worksheets("Players").Cells(Rows.Count, 1).End(xlUp).Row).Value
' add your extra rows to the array here, followed by
ComboBox3.List = Arr
Instead of repeating the same code 40 times, create a loop.
For i = 1 to 40
Cbx = Me.Controls("ComboBox" & Cstr(i))
' then manipulate Cbx as you have done.
Next I
Finally, since your 40 comboboxes are all the same, why not make do with only 1? You can move it around from row to row, let the user make his selection and transfer that selection to a textbox that appears in the place of the Cbx on Exit. When you click on the Tbx again it is substituted by the Cbx so that you have access to the list again.
In the module:
Dim ArrPlayers() as integer
In the userform initialization:
'To Do: add code to populate listbox with players
ReDim ArrPlayers (0 To 39)
On the listbox change event:
txtPosition.text = ArrPlayers(lstPlayers.ListIndex)
On the textbox change event:
ArrPlayers(lstPlayers.ListIndex) = cInt(txtPosition.text)
You will need to then save the values.
use the RowSource property of the combobox control
Option Explicit
Private Sub UserForm_Initialize()
Dim tsheet As Worksheet
Set tsheet = ThisWorkbook.Sheets("Players")
Dim rs As String
rs = "Players!a2:d" & tsheet.Cells(tsheet.Rows.Count, 1).End(xlUp).Row
Dim aaa As Control
For Each aaa In Me.Controls
If Left(aaa.Name, 8) = "ComboBox" Then
aaa.RowSource = rs ' =mySheet!a2:d24 in properties
aaa.ControlSource = "Players!z1" ' put the chosen value into this cell (example)
aaa.ColumnCount = 4
aaa.BoundColumn = 2
aaa.ColumnWidths = "1;50;50;50" ' Hide first column in dropdown
End If
Next aaa
End Sub