返回列表 上一主題 發帖

[發問] 請問如何將各筆數量，依日期範圍加總?

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
1# 跳轉到 »
發表於 2020-3-24 17:23 | 顯示全部帖子
開始與結束日, 有否可能同一天???

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
2#
發表於 2020-3-25 12:21 | 顯示全部帖子
有點複雜, 自行參酌~~

  1. Sub TEST()
  2. Dim Arr, xD(3), d1, d2, i&, j&, k%, U%, Ur, Srr, xS As Worksheet
  3. For j = 0 To 3: Set xD(j) = CreateObject("Scripting.Dictionary"): Next j
  4. Arr = [L2:M30]
  5. For j = 1 To 2: For i = 1 To UBound(Arr)
  6.     If Arr(i, j) <> "" Then xD(0)(Arr(i, j)) = j
  7. Next: Next
  8. '--------------------------------
  9. Arr = Range([J1], Cells(Rows.Count, 1).End(xlUp))
  10. For i = 2 To UBound(Arr)
  11.     d1 = Arr(i, 3): d2 = Arr(i, 4)
  12.     If IsDate(d1) * IsDate(d2) = 0 Then GoTo 101
  13.     U = xD(0)(Arr(i, 2)) + 1
  14.     For j = d1 To d2 - 1
  15.         Ur = xD(U)(j)
  16.         If Not IsArray(Ur) Then Ur = Array(CDate(j), 0, 0, 0, 0, 0, 0)
  17.         For k = 5 To 10: Ur(k - 4) = Ur(k - 4) + Arr(i, k): Next k
  18.         xD(U)(j) = Ur
  19.     Next j
  20. 101: Next i
  21. '--------------------------------
  22. Srr = Array("", "一般", "特殊1", "特殊2")
  23. For k = 1 To 3
  24.     With Sheets(Srr(k))
  25.          .UsedRange.Offset(1, 0).EntireRow.Delete
  26.          U = xD(k).Count: If U = 0 Then GoTo 102
  27.          With .[B2:H2].Resize(U)
  28.               .Value = Application.Transpose(Application.Transpose(xD(k).items))
  29.               .Sort Key1:=.Item(1), Order1:=xlAscending, Header:=xlNo
  30.          End With
  31.     End With
  32. 102: Next k
  33. End Sub
複製代碼


Xl0000054.rar (21.99 KB)


==============================

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
3#
發表於 2020-3-26 17:11 | 顯示全部帖子
回復 8# gaishutsusuru


已修改:
Xl0000054-2.rar (17.78 KB)

TOP

准提部林

帖子
2848 
主題
10 
精華
0 
積分
2903 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2026-7-25 
4#
發表於 2020-3-27 11:46 | 顯示全部帖子
回復 11# gaishutsusuru

若各類匯總結果固定最多6000筆, 可稍簡化:
  1. Sub TEST()
  2. Dim Arr, Brr, xD, r&, c%, i&, j&, k%, N&(2), Sr As Range
  3. [O2:AP6000].Clear: Brr = [O2:AP6000]
  4. Set xD = CreateObject("Scripting.Dictionary")
  5. For Each Sr In [L2:M30]
  6.     k = 1 - k: If Sr <> "" Then xD(Sr & "/") = 2 - k
  7. Next
  8. '--------------------------------
  9. Arr = Range([J1], Cells(Rows.Count, 1).End(xlUp))
  10. For i = 2 To UBound(Arr)
  11.     If IsDate(Arr(i, 3)) * IsDate(Arr(i, 3)) = 0 Then GoTo 101
  12.     c = xD(Arr(i, 2) & "/")
  13.     For j = Arr(i, 3) To Arr(i, 4) - 1
  14.         r = xD(j & "|" & c)
  15.         If r = 0 Then N(c) = N(c) + 1: r = N(c): xD(j & "|" & c) = r
  16.         Brr(r, c * 10 + 2) = CDate(j)
  17.         For k = 3 To 8: Brr(r, c * 10 + k) = Brr(r, c * 10 + k) + Arr(i, k + 2): Next k
  18.     Next j
  19. 101: Next i
  20. '''--------------------------------
  21. [O2:AP6000] = Brr
  22. For Each Sr In Range("P2,Z2,AJ2")
  23.     Sr.Resize(6000, 7).Sort Key1:=Sr, Order1:=xlAscending, Header:=xlNo
  24. Next
  25. MsgBox "~~分類加總完成~~  "
  26. End Sub
複製代碼

TOP

        靜思自在 : 一個缺口的杯子，如果換一個角度看它，它仍然是圓的。
返回列表 上一主題