- 帖子
- 163
- 主題
- 1
- 精華
- 0
- 積分
- 170
- 點名
- 0
- 作業系統
- Window 7
- 軟體版本
- Office 2007
- 閱讀權限
- 20
- 性別
- 男
- 註冊時間
- 2010-9-5
- 最後登錄
- 2022-7-20
|
回復 5# Changbanana
試看看。
結果會寫在I:O欄- Sub test()
- Dim arr()
- Dim dic As Object
- Set dic = CreateObject("scripting.dictionary")
- For i = 2 To Range("A65536").End(3).Row
- If dic.Exists(Cells(i, 1).Value) Then
- dic(Cells(i, 1).Value) = dic(Cells(i, 1).Value) + Cells(i, 5).Value
- Else
- dic(Cells(i, 1).Value) = Cells(i, 5).Value
- n = n + 1
- ReDim Preserve arr(1 To 7, 1 To n)
- For j = 1 To 7
- arr(j, n) = Cells(i, j).Value
- Next j
- End If
- Next i
- For i = 1 To n: arr(5, i) = dic(arr(1, i)): Next i
- Columns("I:O").ClearContents
- [I1].Resize(1, 7) = [A1].Resize(1, 7).Value
- [I2].Resize(n, 7) = Application.Transpose(arr)
- End Sub
複製代碼 |
|