添加列值（日期）对应的工作表

Sub ExtractCompanyData()
    
    ' Define constants.
    
    Const SRC_SHEET_NAME As String = "MasterTable"
    Const DATA_COLUMNS As String = "A:K"
    Const DATE_COLUMN As Long = 2
    Const COMPANY_COLUMN As Long = 3
    Const DST_FIRST_CELL As String = "A1"
    Const DST_DATE_FORMAT As String = "mm\/dd\/yyyy"
    Const DST_SHEET_NAME_DATE_FORMAT As String = "mm-dd-yyyy"
    Const COPY_HEADERS As Boolean = True
 
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Return the source data in an array ('sData').
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    Dim srg As Range: Set srg = sws.UsedRange.Columns(DATA_COLUMNS)
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim cCount As Long: cCount = srg.Columns.Count
    Dim sData() As Variant: sData = srg.Value
    
    ' An Incomplete Description of the Dictionary and the Collection
    ' A dictionary consists of two arrays: one is called 'Keys' and the other
    ' is called 'Items' ('Values'). Each key has an associated item
    ' and they form a so-called 'key-value pair'.
    ' Each key needs to be unique while its item can hold various data types,
    ' in this case, a collection ('object').
    ' A collection is similar but simpler.
    ' Each of a collection's 'item' needs to be unique.
    ' The collection is used because it is more efficient and you can simply
    ' add just an item to it while you need to add a value pair to a dictionary.
    
    ' Return the unique dates ('sDate') from the source array ('sData')
    ' in the 'keys' of a dictionary.
    ' Each key's corresponding 'item' will hold a collection whose 'items'
    ' will hold the rows ('sr') where each date ('sDate', key) was found.
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Dim sDate As Variant, sr As Long
    
    For sr = 2 To srCount ' skip headers
        sDate = sData(sr, DATE_COLUMN)
        If IsDate(sDate) Then
            If Not dict.Exists(sDate) Then
                ' Create the 'sDate' key in the dictionary
                ' and add a new collection to the key's associated item.
                dict.Add sDate, New Collection
                ' or:
                'Set dict(sDate) = New Collection
            End If
            dict(sDate).Add sr ' add the row to the items of the collection
        End If
    Next sr

    ' Loop through the keys (dates) of the dictionary, and by applying
    ' the required logic, copy the data to the destination worksheet.

    Application.ScreenUpdating = False

    Dim dws As Worksheet, drg As Range, ddrg As Range
    Dim dData() As Variant, sRow As Variant
    Dim dr As Long, idr As Long, drCount As Long, c As Long
    Dim dwsName As String, Company As String, IsCompanyFound As Boolean
    
    ' Loop through the keys (dates) of the dictionary.
    For Each sDate In dict.Keys
        
        ' Define the destination array.
        drCount = dict(sDate).Count - COPY_HEADERS
        ReDim dData(1 To drCount, 1 To cCount)
        
        ' Write the headers to the destination array.
        ' Also, determine the used destination array rows ('idr', 'dr')
        ' i.e. the inital row, the first row to be written to minus one.
        If COPY_HEADERS Then
            For c = 1 To cCount
                dData(1, c) = sData(1, c)
            Next c
            idr = 1
        Else
            idr = 0
        End If
        dr = idr
        
        ' Loop through the items ('sRow') of the collection ('dict(sDate)'),
        ' held by the current key's ('dDate') corresponding item ('dict(sDate)'),
        ' and write the values from each corresponding row ('sRow')
        ' of the source array ('sData') to the next row ('dr')
        ' of destination array ('dData') skipping the company column.
        ' Also, attempt to determine the company name.
        For Each sRow In dict(sDate)
            dr = dr + 1
            For c = 1 To cCount
                If c <> COMPANY_COLUMN Then
                    dData(dr, c) = sData(sRow, c)
                End If
            Next c
            If Not IsCompanyFound Then
                Company = CStr(sData(sRow, COMPANY_COLUMN))
                If Len(Company) > 0 Then IsCompanyFound = True
            End If
        Next sRow
        
        ' Loop through the rows ('dr') of the destination array ('dData')
        ' and write the company name ('Company') to the company column.
        If IsCompanyFound Then
            For dr = idr + 1 To drCount
                dData(dr, COMPANY_COLUMN) = Company
            Next dr
            IsCompanyFound = False ' reset for the next iteration
        End If
        
        ' Determine the destination worksheet name ('dwsName').
        dwsName = Format(sDate, DST_SHEET_NAME_DATE_FORMAT)
        
        ' Delete an existing same named sheet.
        Application.DisplayAlerts = False
            On Error Resume Next
                wb.Sheets(dwsName).Delete
            On Error GoTo 0
        Application.DisplayAlerts = True
        
        ' Add a new worksheet ('dws') and rename it accordingly.
        Set dws = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count))
        dws.Name = dwsName
        
        ' Copy the values from the destination array ('dData')
        ' to the destination range ('drg').
        Set drg = dws.Range(DST_FIRST_CELL).Resize(drCount, cCount)
        drg.Value = dData
        
        ' Apply formatting to the destination (range, worksheet).
        With drg
            ' Format headers and reference the destination data range ('ddrg').
            If COPY_HEADERS Then
                With .Rows(1)
                    .Font.Bold = True
                End With
                Set ddrg = drg.Resize(drCount - 1).Offset(1)
            Else
                Set ddrg = drg
            End If
            ' Format the destination data range ('ddrg').
            With ddrg
                ' Format the destination date column.
                With ddrg.Columns(DATE_COLUMN)
                    .NumberFormat = DST_DATE_FORMAT
                End With
            End With
            ' Format the entire destination columns.
            .EntireColumn.AutoFit
        End With
        
    Next sDate
    
    ' Additional Ideas
    
    'sws.Activate
    'wb.Save

    Application.ScreenUpdating = True
    
    ' Inform.
    
    MsgBox "Company data extracted.", vbInformation
    
End Sub

一个视觉呈现的人口字典