Hsieh

回復 1# freeffly

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range([A2], [A65536].End(xlUp))
   
4.    d(a & a.Offset(, 2)) = ""
   
5.    a.Offset(, 6) = "A" & d.Count
   
6. Next
   
7. End Sub

複製代碼

Hsieh

回復 3# freeffly

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range([A2], [A65536].End(xlUp))
   
4.    m = a & a.Offset(, 2) & Split(a.Offset(, 3), "-")(1)
   
5.    If IsEmpty(d(m)) Then
   
6.       d(m) = Array(1, a.Offset(, 5))
   
7.    Else
   
8.       ar = d(m)
   
9.       If ar(1) <> a.Offset(, 5) Then
   
10.       ar(0) = ar(0) + 1
    
11.       d(m) = ar
    
12.       End If
    
13.       Erase ar
    
14.    End If
    
15. Next
    
16. For Each ky In d.keys
    
17.   If d(ky)(0) = 1 Then d.Remove ky
    
18. Next
    
19. 
    
20. For Each a In Range([A2], [A65536].End(xlUp))
    
21.    m = a & a.Offset(, 2) & Split(a.Offset(, 3), "-")(1)
    
22.    i = Application.Match(m, d.keys, 0)
    
23.    If IsNumeric(i) Then
    
24.    a.Offset(, 6) = "A" & i
    
25.    Else
    
26.    a.Offset(, 6) = ""
    
27.    End If
    
28. Next
    
29. 
    
30. End Sub

複製代碼

Hsieh

回復 5# freeffly
因為是以A欄作客戶資料
所以必須將A欄客戶代號填滿

Hsieh

回復 7# freeffly

1. Sub ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range([A2], [A65536].End(xlUp))
   
4.    m = a & a.Offset(, 2) & Split(a.Offset(, 3), "-")(1) '串接A、C欄與D欄的日期部分字串
   
5.    If IsEmpty(d(m)) Then '當字典以m為索引的內容初始化時執行
   
6.       d(m) = Array(1, a.Offset(, 5)) '將A欄與F欄為陣列賦給m為索引的內容
   
7.       
   
8.    Else '當出現第二個以上的m
   
9.       ar = d(m) '取出字典內容
   
10.       If ar(1) <> a.Offset(, 5) Then '當陣列第二個元素值與F欄不同
    
11.       ar(0) = ar(0) + 1 '陣列第一個值加一，當成同索引且單價不同的計數
    
12.       d(m) = ar '將陣列回存到字典
    
13.       End If
    
14.       Erase ar '清除陣列
    
15.    End If
    
16. Next
    
17. For Each ky In d.keys
    
18.   If d(ky)(0) = 1 Then d.Remove ky '如果字典內容第一個項目是1，也就是單一計數就移除該索引內容
    
19. Next
    
20. 
    
21. For Each a In Range([A2], [A65536].End(xlUp))
    
22.    m = a & a.Offset(, 2) & Split(a.Offset(, 3), "-")(1)
    
23.    i = Application.Match(m, d.keys, 0) '取得該字串是字典第幾個項目
    
24.    If IsNumeric(i) Then
    
25.    a.Offset(, 6) = "A" & i '寫入編號
    
26.    Else
    
27.    a.Offset(, 6) = "" '不字典內就清空G欄
    
28.    End If
    
29. Next
    
30. 
    
31. End Sub

複製代碼