GBKEE

回復 4# hkyan

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng As Range, i As Integer, ii As Integer, R As Range, d1 As Object, d2 As Object
   
4.     Set d1 = CreateObject("SCRIPTING.DICTIONARY")        '字典物件
   
5.     Set d2 = CreateObject("SCRIPTING.DICTIONARY")        '字典物件
   
6.     i = 2               '從B2欄數 開始
   
7.     With ActiveSheet    '指定工作表
   
8.         Do While .Cells(1, i) <> ""             '執行迴圈的條件: i欄的第一列 <>""
   
9.             If Weekday(.Cells(1, i), 2) = 6 Then '日期的星期="週六"
   
10.                 If Not Rng Is Nothing Then      '設定"週六"的位置
    
11.                     Set Rng = Union(Rng, .Cells(1, i))
    
12.                 Else
    
13.                     Set Rng = .Cells(1, i)
    
14.                 End If
    
15.             End If
    
16.             i = i + 1                           '下一個欄數
    
17.         Loop
    
18.         i = 2                                   '從A2列數 開始
    
19.         Do While .Cells(i, "A") <> ""           '執行迴圈的條件: A欄的i列 <>""
    
20.             '字典物件(KEY)對應一個 Item
    
21.             d1(.Cells(i, "A").Value) = ""       '字典物件(KEY)的ITEM =""
    
22.             d2(.Cells(i, "A").Value) = ""
    
23.             For Each R In Rng                   '每一個 R 的星期都是"週六"
    
24.                 If R.Cells(i) <> "" Then        'R.Cells(i):  R下方第i個Cell
    
25.                     d1(.Cells(i, "A").Value) = Val(d1(.Cells(i, "A").Value)) + 1
    
26.                                                 '字典物件(KEY) =VAL(字典物件(KEY))+1 (對應的 Item)
    
27.                     d2(.Cells(i, "A").Value) = Date - R
    
28.                                                 '字典物件(KEY) =當日- R [天數](對應的 Item)
    
29.                 End If
    
30.             Next
    
31.             i = i + 1
    
32.         Loop
    
33.         Range("R2").Resize(d1.Count).Value = Application.Transpose(d1.ITEMS)
    
34.         Range("S2").Resize(d1.Count).Value = Application.Transpose(d2.ITEMS)
    
35.         
    
36.     End With
    
37. End Sub

複製代碼