How to extract values of multiple listboxes on Excel sheet? - excel

Question

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

Answer 1

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