如何在Excel工作表上提取多個列表框的值？

Question

我有一個帶有多個復選框和列表框的用戶表單，其中每個復選框控制一個列表框的值。

單擊“下一步”后，用戶表單將在 Excel 工作表上輸入每個列表框的選定值。 我一次只能為一對復選框和列表框實現這一點。 但我想要一個接一個地列出每個入圍項目的結果。

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

將選定的列表框項目提取到工作表

由於您不會在行編號中產生結果（永遠不會更改 lastrow 與額外的偏移量和增量混合），因此您正在失去對實際行號的跟蹤。 使用 Sub 過程（此處： WriteItems ）進行重復調用並每次重新定義最后一行（此處：開始行）也是更好的做法。 此外，我演示了如何使用Application.Index()函數提取整個列表框“行”。

進一步提示：考慮使用條件格式 (CF)，而不是直接格式化，因為您不需要清除已刪除單元格中的舊格式（確保您在 SO 中找到了很多示例：-）

順便說一句，我更願意避免包含下划線“_”的控件名稱，因為這在類實現中具有一定的相關性。

主要活動

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

子過程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

進一步注意： Application.Index函數允許通過傳遞零 (..,0) 作為第二個函數參數來獲取整個列表框“行”。

輔助函數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