- 帖子
- 192
- 主題
- 15
- 精華
- 0
- 積分
- 194
- 點名
- 0
- 作業系統
- windows
- 軟體版本
- office2010
- 閱讀權限
- 20
- 性別
- 女
- 註冊時間
- 2016-9-22
- 最後登錄
- 2020-8-28
 
|
2#
發表於 2016-12-7 10:04
| 只看該作者
本帖最後由 starbox520 於 2016-12-7 10:06 編輯
回復 1# starbox520
已寫出來摟~各位高手指點指點><"- Sub ttt()
- Dim dic As Object, brr, i%, arr(1 To 5000, 1 To 4)
- brr = Sheet3.Range("a1").CurrentRegion
- Set dic = CreateObject("Scripting.Dictionary")
- For i = 2 To UBound(brr)
- s = brr(i, 4) & brr(i, 8) & brr(i, 9)
- If Not dic.Exists(s) Then
- n = n + 1
- dic(s) = n
- arr(n, 1) = brr(i, 8)
- arr(n, 2) = brr(i, 4)
- arr(n, 3) = brr(i, 9)
- arr(n, 4) = 1
- Else
- arr(dic(s), 4) = arr(dic(s), 4) + 1
- End If
- Next
- If n > 1 Then
- With Sheet4.Range("a1")
- .CurrentRegion.Offset(1).ClearContents
- .Offset(1).Resize(n, 4) = arr
- End With
- End If
- Set dic = Nothing
- End Sub
|
|
