主页 / coding / 问题 / 79106361
Accepted
Shiela
Asked: 2024-10-20 12:23:27 +0800 CST

带日期条件/过滤器的 VBA 案例

  • 772

使用以前的文章，我添加了：

  • 新列为名称和日期
  • 新增 6 个标签（丹的每日和每月计数、丽莎的每日和每月计数、每日总计数和每月计数）
  • 新建列表框2

我遇到一个问题，在 Listbox1 的结果是今天的输入（每日）而 Listbox2 是当月的输入（每月）的情况下，如何插入日期过滤条件。

这是来自 Excel Sheet1 的原始数据：

ID      Name    Status      Date
1201    Lisa    Pending A   10/14/2024
1202    Lisa    In progress 10/15/2024
1203    Dan     Pending A   10/16/2024
1204    Dan     Pending B   10/17/2024
1205    Dan     Pending C   10/17/2024
1206    Dan     Pending B   10/18/2024
1207    Lisa    Pending B   10/19/2024
1208    Dan     Pending B   10/19/2024
1209    Lisa    Pending A   10/19/2024

在此处输入图片描述

这是得出的代码：

Private Sub UserForm_Initialize()
        
    ' Define constants.
    Const CRITERIA_COLUMN As Long = 3
    
    ' Return the values of the range in an array.
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
    Dim rng As Range:
    Set rng = ws.Range("A1:D" & ws.Cells(ws.Rows.count, "C").End(xlUp).Row)
    Dim sRowsCount As Long: sRowsCount = rng.Rows.count
    Dim ColumnsCount As Long: ColumnsCount = rng.Columns.count
    Dim sData() As Variant: sData = rng.Value
    
    ' Return the matching source row numbers in a collection.
    Dim coll As Collection: Set coll = New Collection
    Dim sr As Long
    For sr = 2 To sRowsCount
        Select Case CStr(sData(sr, CRITERIA_COLUMN))
            Case "Pending A", "Pending B" '**** would like to put a date condition here or anywhere in the whole code to get result
                coll.Add sr
        End Select
    Next sr
    
    ' Define the destination array
    Dim dRowsCount As Long: dRowsCount = coll.count
    If dRowsCount = 0 Then Exit Sub ' no matches
    Dim dData() As Variant: ReDim dData(1 To dRowsCount, 1 To ColumnsCount)
    
    ' Loop through the items (matching source rows) of the collection
    ' to populate the destination array.
    Dim srItem As Variant, dr As Long, c As Long
    For Each srItem In coll
        dr = dr + 1
        For c = 1 To ColumnsCount
            dData(dr, c) = sData(srItem, c)
        Next c
    Next srItem
         
    ' Populate the listbox...
    With Me.ListBox1
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    
    With Me.ListBox2
        .ColumnHeads = True
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        '.List = dData
    End With
    
    ' ... and the label.
    'LabelDanDaily.Caption =
    'LabelLisaDaily.Caption =
    
    'LabelDanMonthly.Caption =
    'LabelLisaMonthly.Caption =
    
    'LabelTotalDaily.Caption =
    LabelTotalMonthly.Caption = dRowsCount
        
End Sub

这是所需的输出：

每日每月

如何根据每日和每月日期过滤器获取列表框以及标签中的计数？

excel

1 个回答

  1. Best Answer

    添加第二个集合来存储 ListBox2 所需的数据行。

    注意：列表框列标题不能通过.List属性设置。请参考您之前的帖子：

    如何用 VBA 显示列表框中的最后 10 个条目

    Option Explicit

Private Sub UserForm_Initialize()
    
    ' Define constants.
    Const CRITERIA_COLUMN As Long = 3
    Const DATE_COLUMN As Long = 4
    
    ' Return the values of the range in an array.
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Sheets("Sheet1")
    Dim rng As Range:
    Set rng = ws.Range("A1:D" & ws.Cells(ws.Rows.Count, "C").End(xlUp).Row)
    Dim sRowsCount As Long: sRowsCount = rng.Rows.Count
    Dim ColumnsCount As Long: ColumnsCount = rng.Columns.Count
    Dim sData As Variant: sData = rng.Value
    
    ' Return the matching source row numbers in a collection.
    Dim coll1 As Collection: Set coll1 = New Collection
    Dim coll2 As Collection: Set coll2 = New Collection
    Dim sr As Long, iDate As Date
    For sr = 2 To sRowsCount
        Select Case CStr(sData(sr, CRITERIA_COLUMN))
        Case "Pending A", "Pending B" '**** would like to put a date condition here or anywhere in the whole code to get result
            If IsDate(sData(sr, DATE_COLUMN)) Then
                iDate = CDate(sData(sr, DATE_COLUMN))
                If Month(iDate) = Month(Date) And Year(iDate) = Year(Date) Then
                    coll2.Add sr ' for ListBox2
                    If CDbl(iDate) = CDbl(Date) Then
                        coll1.Add sr ' for ListBox1
                    End If
                End If
            End If
        End Select
    Next sr
    
    ' Define the destination array
    Dim dData() As Variant
    ' ** for ListBox 2
    If coll2.Count = 0 Then Exit Sub
    Col2Arr coll2, dData, sData, ColumnsCount
    With Me.ListBox2
        .ColumnHeads = False
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    ' ** for ListBox 1
    If coll1.Count = 0 Then Exit Sub
    Col2Arr coll1, dData, sData, ColumnsCount
    With Me.ListBox1
        .ColumnHeads = False
        .ColumnWidths = "30,30,50,30"
        .ColumnCount = ColumnsCount
        .List = dData
    End With
    
End Sub

Sub Col2Arr(ByRef Col As Collection, ByRef dData As Variant, _
        ByVal sData As Variant, ByVal ColumnsCount As Long)
    Dim dRowsCount As Long: dRowsCount = Col.Count
    ReDim dData(1 To dRowsCount + 1, 1 To ColumnsCount)
    Dim c As Long, srItem
    For c = 1 To ColumnsCount
        dData(1, c) = sData(1, c)
    Next
    Dim dr As Long: dr = 1
    For Each srItem In Col
        dr = dr + 1
        For c = 1 To ColumnsCount
            dData(dr, c) = sData(srItem, c)
        Next c
    Next srItem
End Sub

    在此处输入图片描述

    • 1

相关问题