如何提取Excel工作表上多个列表框的值？_Excel_Vba_Forms_Userform

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

excel vba forms

如何提取Excel工作表上多个列表框的值？,excel,vba,forms,userform,Excel,Vba,Forms,Userform,我有一个带有多个复选框和列表框的用户表单，其中每个复选框控制每个列表框的值单击“下一步”后，用户表单在Excel工作表上输入每个列表框的选定值。我一次只能通过一对复选框和列表框来实现这一点。但是我想要一个接一个的每个入围项目的结果 Private Sub cmdFDB_Next_Click() Dim ColCount As Integer, lastrow As Integer Dim lastrow1 As Integer Dim Data As Integer Dim i As Inte

我有一个带有多个复选框和列表框的用户表单，其中每个复选框控制每个列表框的值

单击“下一步”后，用户表单在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

将选定的列表框项目提取到工作表中

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

），并每次重新定义最后一行（此处：开始行）。此外，我还演示了如何使用

Application.Index（）

函数提取整个列表框“行”

进一步提示：代替直接格式化，考虑使用条件格式化（CF），因为您不必在已删除的单元格中清除旧格式（当然，您在SO：-）找到了许多示例

顺便说一句，我希望避免控件名包含下划线“\ux”，因为这在类实现中有一定的相关性

主要活动

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

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