依日期來分別統計公司人數

sillykin

依日期來分別統計公司人數,不知用那一個函數來統計

jcchiang

回復 1# sillykin
B2右拉=SUM(SUMPRODUCT((資料庫!$B:$B=總表單!B$1)*(資料庫!$F:$F=總表單!$A$2)),SUMPRODUCT((資料庫!$J:$J=總表單!B$1)*(資料庫!$N:$N=總表單!$A$2)))

hcm19522

=SUMPRODUCT((資料庫!$B$3:$J$999=B$1)*(資料庫!$F$3:$N$999=$A2))

准提部林

=SUMPRODUCT((資料庫!$B$2:$B$600=B$1)*(資料庫!$F$2:$F$600=$A2)+(資料庫!$J$2:$J$600=B$1)*(資料庫!$N$2:$N$600=$A2))

公式較長, 但公式計算量少~~

Andy2483

回復 1# sillykin


    謝謝前輩發表此主題與範例
後學藉此主題學習字典與陣列得到多種知識與經驗,以下是後學練習VBA方式的方案,請前輩參考
請前輩們指導,謝謝

執行前:

下載 (86.98 KB)

2023-1-3 15:01

結果與警訊1:

下載 (91.5 KB)

2023-1-3 15:01

結果與警訊2:

下載 (92.3 KB)

2023-1-3 15:02

Option Explicit
Sub 依日期來分別統計公司人數_20230103_1()
Dim R&, i&, j&, N&, Q&, T1$, T2$, T4$, Qv$, Y, Brr, Crr, C, Sh1, Sh2
'↑宣告變數:(R,i,j,N,Q)是長整數變數,(T1,T2,T4,Qv)是字串變數,其它是通用型變數
Set Y = CreateObject("Scripting.Dictionary")
'↑令Y是 字典
Set Sh1 = Sheets("資料庫")
'↑令Sh1是 "資料庫"工作表
Set Sh2 = Sheets("總表單")
'↑令Sh2是 "總表單"工作表
Brr = Sh1.Range("A3:N" & Split(Sh1.UsedRange.Address, "$")(4))
'↑令Brr是二維陣列!倒入[A3]到N欄最後列儲存格
R = Sh2.Cells(Rows.Count, "A").End(3).Row
'↑令R這整數變數是 "總表單"工作表A欄最後有內容儲存格列號
C = Sh2.Cells(1, Columns.Count).End(1).Column
'↑令C這整數變數是 "總表單"工作表第1列最右側有內容儲存格欄號
Range(Sh2.Cells(R, 1), Sh2.Cells(1, C)).Offset(1, 1).ClearContents
'↑令"總表單"工作表[A1]到R列C欄儲存格範圍偏移往下1列,偏移往右1欄儲存格值清除
Crr = Range(Sh2.Cells(R, 1), Sh2.Cells(1, C))
'↑令Crr是二維陣列!倒入"總表單"工作表[A1]到R列C欄儲存格值
For i = 2 To UBound(Crr, 2)
'↑設順迴圈!i從2到Crr陣列橫向最大索引欄號數
   Y(Crr(1, i) & "|C") = i
   '↑令1列i迴圈欄Crr陣列值連接"|C"當key,item是i迴圈數,放入Y字典裡
Next
For i = 2 To UBound(Crr)
'↑設順迴圈!i從2到Crr陣列縱向最大索引列號數
   Y(Crr(i, 1) & "|R") = i
   '↑令i迴圈列1欄Crr陣列值連接"|R"當key,item是i迴圈數,放入Y字典裡
Next
For Each C In [{2,10}]
'↑設順迴圈!令C是一維陣列裡的一員
   For R = 1 To UBound(Brr)
   '↑設順迴圈!令R從1到Brr陣列縱向最大索引列號數
      T1 = Trim(Brr(R, C))
      '↑令T1是 R迴圈列C迴圈欄Brr陣列值去除字串頭尾的空白字元
      T2 = Trim(Brr(R, C + 2))
      '↑令T2是 R迴圈列C+2迴圈欄Brr陣列值去除字串頭尾的空白字元
      T4 = Trim(Brr(R, C + 4))
      '↑令T4是 R迴圈列C+4迴圈欄Brr陣列值去除字串頭尾的空白字元
      If T1 = "" Or T4 = "" Then GoTo PS
      '↑如果T1字串變數是空字元或 如果T4字串變數是空字元,就跳到PS:位置繼續執行
      If Y(T1 & "|C") <> "" And Y(T4 & "|R") <> "" Then
      '↑如果用T1變數連接"|C"查Y字典不是空字元 而且 用T4變數連接"|R"查Y字典不是空字元??
         If T2 <> "" Then
         '↑如果T2變數不是空字元?
            i = Y(Trim(Brr(R, C + 4)) & "|R"): j = Y(Trim(Brr(R, C)) & "|C")
            '↑令i是 申請日去除頭尾空白字元後連接"|R"查Y字典得到的item值
            '↑令j是 單位/分社去除頭尾空白字元後連接"|C"查Y字典得到的item值
            Crr(i, j) = Crr(i, j) + 1
            '↑令i列j欄Crr陣列值 +1
            Else
               N = N + 1
               '↑否則令N整數變數+1
         End If
         ElseIf Y(T1 & "|C") = "" And Y(T4 & "|R") <> "" Then
         '↑否則如果T1字串變數連接"|C"查Y字典地item值是空字元,
         '而且T4字串變數連接"|R"查Y字典不是空字元
            Q = Q + 1
            '↑令Q整數變數+1
            Qv = Qv & "," & T1
            '↑令Qv這字串變數是 自身值連接",",再連接T1字串變數
      End If
PS:
   Next
Next
Sh2.[A1].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
'↑令"總表單"工作表向下擴展Crr陣列縱向最大索引列號數,
'向右Crr陣列橫向最大索引欄號數,這範圍儲存格值以Crr陣列值帶入
Application.Goto Sh2.[A1]
'↑令儲存格游標跳到 "總表單"工作表[A1]
If N > 0 Then MsgBox "共有 " & N & "筆資料沒有姓名,未列入統計"
If Q > 0 Then MsgBox "共有 " & Q & "單位/分社在 總表單找不到" & Qv
Set Y = Nothing
Set Brr = Nothing
Set Crr = Nothing
'↑釋放變數
End Sub

Andy2483

回復 5# Andy2483


    統計各日期_各公司人數_排除重複

資料庫:

下載 (236.97 KB)

2023-1-4 10:52

總表單_清除資料:

下載 (59.75 KB)

2023-1-4 10:52

執行結果:

下載 (76.36 KB)

2023-1-4 10:53

Option Explicit
Sub 統計各日期_各公司人數_排除重複_1()
Dim i&, u&, C&, R&, v&, Shr&, T2$, T4$, T6$, TT$
Dim Arr, Crr, Y, Z, xR, Sh1, Sh2, Sha
Set Z = CreateObject("Scripting.Dictionary")
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("資料庫")
Set Sh2 = Sheets("總表單")
Set Sha = Sh1.Range("A3:G" & Split(Sh1.UsedRange.Address, "$")(4))
Shr = Sha.Rows.Count
Sha.Copy Sh2.[A1]
Sha.Offset(, 8).Copy Sh2.Cells(Shr + 1, 1)
With Sh2.UsedRange
    .Replace What:=" ", Replacement:="", LookAt:=xlPart
    .Sort _
      KEY1:=.Item(6), Order1:=xlAscending, _
      Key2:=.Item(2), Order2:=xlAscending, _
      Header:=xlNo, Orientation:=xlTopToBottom
    Arr = .Value
    .EntireRow.Delete
End With
For i = 1 To UBound(Arr)
   If Not Z.Exists(Arr(i, 6)) And Arr(i, 6) <> "" Then
      Z(Arr(i, 6)) = Z.Count + 1
   End If
   If Not Y.Exists(Arr(i, 2)) And Arr(i, 2) <> "" Then
      Y(Arr(i, 2)) = Y.Count + 1
   End If
Next
R = Z.Count
Sh2.[A2].Resize(R, 1) = Application.Transpose(Z.KEYS)
C = Y.Count
Sh2.[B1].Resize(1, C) = Y.KEYS
ReDim Crr(R, C)
For i = 1 To UBound(Arr)
   T2 = Arr(i, 2)
   T4 = Trim(Arr(i, 4))
   T6 = Trim(Arr(i, 6))
   TT = T2 & "|" & T4 & "|" & T6 & "|"
   If Y.Exists(TT) Then GoTo PP
   If Y(T2) <> "" And Z(T6) <> "" And T4 <> "" Then
      v = Z(Arr(i, 6)) - 1: u = Y(Arr(i, 2)) - 1
      Crr(v, u) = Crr(v, u) + 1
      Y(TT) = 1
   End If
PP:
Next
Sh2.[B2].Resize(UBound(Crr), UBound(Crr, 2)) = Crr
Sh2.Range(Sh2.[A1], Sh2.Cells(R + 1, C + 1)).Borders.LineStyle = 1
Application.Goto Sh2.[A1]
Set Y = Nothing
Set Z = Nothing
Set Arr = Nothing
Set Crr = Nothing
End Sub

Andy2483

回復 4# 准提部林


    謝謝前輩
Option Explicit
Sub 統計各日期_各公司人數_排除重複_2()
Dim i&, C&, N&, N2&, N6&, R%, k%, T2$, T4$, T6$, TT$
Dim S(2), Crr, Y, Sha, Sh1, Sh2
Set Y = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("資料庫")
Set Sh2 = Sheets("總表單")
Set Sha = Range(Sh1.[A3], Sh1.Cells(Sh1.Cells.SpecialCells(xlLastCell).Row, "G"))
S(1) = Sha '陣列中陣列,今天剛學到的 http://forum.twbts.com/thread-23571-1-1.html
S(2) = Sha.Offset(, 8) '陣列中陣列
N = Sha.Rows.Count
Sh2.UsedRange.EntireRow.Delete
ReDim Crr(10000, N) '從0,0開始
For k = 1 To 2
   For i = 1 To N
      T2 = Trim(S(k)(i, 2)): T4 = Trim(S(k)(i, 4)): T6 = Trim(S(k)(i, 6))
      TT = "|" & T2 & "|" & T4 & "|" & T6 & "|"
      If InStr(TT, Application.Rept("|", 2)) Then GoTo PP '排除空格
      If Y.Exists(TT) Then GoTo PP '排除重複
      If Not Y.Exists(T2 & "|C") Then
         Y(T2 & "|C") = N2
         Crr(0, N2 + 1) = T2 '標題列
         N2 = N2 + 1
      End If
      If Not Y.Exists(T6 & "|R") Then
         Y(T6 & "|R") = N6
         Crr(N6 + 1, 0) = T6 '標題欄
         N6 = N6 + 1
      End If
      R = Y(T6 & "|R"): C = Y(T2 & "|C")
      Crr(R + 1, C + 1) = Crr(R + 1, C + 1) + 1 '累加數量
      Y(TT) = 1 '標記存在
PP:
   Next
Next
With Sh2.[A1].Resize(N6 + 1, N2 + 1)
   .Value = Crr
   .Offset(, 1).Sort Key1:=.Cells(1, 2), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   .Offset(1).Sort Key1:=.Cells(2, 1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
   .Borders.LineStyle = 1
End With
Set Y = Nothing: Set Crr = Nothing: Erase S
End Sub