VBA-003.多表日期彙總求和

1、需求

如下圖：一個車號一個工作表且格式一樣，現根據各工作表B列日期，按照彙總表的第一行月份2019年1月、2月······統計出各車號的E列金額。麻煩各位老師幫看看怎麼寫代碼

2、思路分析

1）彙總條件是年+月，所以需要將數據表中的相關數據按照年+月的形式彙總求和

2）將彙總後的結果與彙總條件比對，對坐入號

3）因為要對每個數據表進行日期彙總求和，所以將此功能單獨剝離，主過程中調用即可，減少代碼調試困難

3、代碼

<code>Sub 名稱彙總()
'   ws_name：工作表名變量參數，字符型
'   last_row: 彙總表已使用區域的總行數，數值型
'   retruan_arr：接收日期彙總功能的返回值，數組類型
'   dt：存儲年+月的變量，字符型
    Dim ws_name As String, i&, last_row&, return_arr, x&, dt As String
    
    last_row = ActiveSheet.UsedRange.Rows.Count
    Range("e2:v" & last_row).ClearContents
'   return_arr接收所有數據表的返回值
    ReDim return_arr(1 To last_row)
    
    For i = 2 To last_row
        ws_name = Cells(i, 3)
        '   案例存在多張隱藏表，且隱藏表的結構與其他數據表結構不一，故使用隱藏判斷跳過不予彙總
        '   如果工作簿中無隱藏表，此判斷可刪除
        '   Visible = -1，表示工作表為可見狀態
        If Worksheets(ws_name).Visible = -1 Then
            '   將所有的數據表（結果是一個二維數組）嵌套寫入一個一維數組中，整體形成一個三維數組
            return_arr(i - 1) = 日期彙總(ws_name)
        End If
    Next i
    
'   彙總表區域的日期與return_arr中的日期維度相比較，如一致則寫入對應的單元格中
    For i = 1 To last_row
    '   彙總表的日期區域，即E1:V1區域，共計18個月
        For x = 1 To 18
        '   因為表中存在隱藏表，故return_arr一維數組存在空白佔位元素，故須進行忽略錯誤處理
            On Error Resume Next
            '   循環return_arr每個數據表中的日期維度
            For y = 1 To UBound(return_arr(i), 1)
                dt = Year(Cells(1, x + 4)) & "-" & Month(Cells(1, x + 4))
                If dt = return_arr(i)(y, 1) Then
                '   return_arr(i)(y,2)：return_arr第i個元素中第y行，第2列的元素
                    Cells(i + 1, x + 4) = return_arr(i)(y, 2)
                End If
            Next y
        Next x
    Next i
End Sub


Function 日期彙總(ws_name As String)
    
    Dim arr, last_row, x&, brr(), i&, temp As String
    last_row = Worksheets(ws_name).UsedRange.Rows.Count
    arr = Worksheets(ws_name).Range("b2:e" & last_row)

    For x = 1 To last_row
    
    '   將2019/1/24改為年+月格式，即2019-4
        temp = Year(arr(x, 1)) & "-" & Month(arr(x, 1))
        On Error Resume Next
        '   檢測工作表的B列日期處理後的temp是否已存在於brr數組中，如存在，則對應元素累加，否則新增相應元素
        '   match函數的第二個參數Array必須是一維數組，而brr是二維數組，故須使用Index函數提取單維數據
        '   Index(brr,1,0)：brr是一個行數為2，列數不固定的數組，第一行值為日期，第二行值為金額累加值，故此句的意思即提取brr的第一行數據，也就是日期行
        temp = Application.WorksheetFunction.Match(temp, Application.WorksheetFunction.Index(brr, 1, 0), 0)
        '   如果元素存在數組中，則程序不報錯，即Err=0，否則程序報錯，Err＞0
        If Err = 0 Then
            brr(2, Int(temp)) = brr(2, Int(temp)) + arr(x, 4)
        Else
            i = i + 1
            ReDim Preserve brr(1 To 2, 1 To i)
            brr(1, i) = temp
            brr(2, i) = arr(x, 4)
        End If
    Next x
    '   個人習慣，將日期行與金額行轉置為日期列與金額列，便於主過程使用
    日期彙總 = Application.WorksheetFunction.Transpose(brr)
    
End Function
/<code>