Início / coding / Perguntas / 79106361
Accepted
Shiela
Asked: 2024-10-20 12:23:27 +0800 CST

Caso com condição/filtro de data VBA

  • 772

Usando o post anterior , adicionei:

  • Novas colunas que são Nome e Data
  • Novos 6 rótulos (contagens diárias e mensais de Dan, contagens diárias e mensais de Lisa, contagem diária total e contagens mensais)
  • Nova listbox2

Estou tendo um problema sobre como inserir uma condição de filtragem de data no caso em que o resultado do Listbox1 é para as entradas de hoje (diário), enquanto o Listbox2 é para as entradas do mês (mensal).

Estes são os dados brutos da Planilha Excel 1:

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

insira a descrição da imagem aqui

Este é o código derivado:

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

Esta é a saída desejada:

diáriomensal

Como obter as caixas de listagem de acordo com o filtro de data diário e mensal, bem como as contagens nos rótulos?

excel

1 respostas

  1. Best Answer

    Adicione a segunda coleção para armazenar as linhas de dados desejadas para ListBox2.

    Nota: Os cabeçalhos de coluna da caixa de listagem não podem ser definidos por.Listpropriedade. Consulte sua postagem anterior:

    Como mostrar as últimas 10 entradas na caixa de listagem feita em VBA

    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

    insira a descrição da imagem aqui

    • 1

relate perguntas