麻辣家族討論版版 - Powered by Discuz! Board

Sub ex()
Dim Ay(2), MyID%, Ary(2)
Set d = CreateObject("Scripting.Dictionary")
ar = Range("A1").CurrentRegion '將表格寫入陣列
i = 2 '第2列開始
Do
j = 4 '第4欄開始
Do
MyID = IIf(ar(i, 2) = "Add", 0, 1) '第2欄如果是Add就用0否則用1作為陣列索引
Ay(MyID) = Ay(MyID) + ar(i, j) '將陣列值相加
j = j + 1 '欄位加1
Loop Until j > UBound(ar, 2) Or TypeName(Cells(1, j).Value) = "String" '直到欄位大過表格欄位或是第一列的值是字串(避免第2次執行會計算到原本新增的統計位置)
Cells(i, j).Resize(, 2) = Ay '資料列的後面欄位加入加總值
Erase Ay
i = i + 1 '列數加1
Loop Until i > UBound(ar, 1) Or Cells(i, 1) = "" '直到列數大過表格列數或第1欄為空白
Cells(i, j) = "=SUM(R2C:R[-1]C)": Cells(i + 1, j + 1) = "=SUM(R2C:R[-1]C)" '表格右下方寫入公式
Cells(1, j).Resize(, 2) = Array("Count_Add", "Count_None") '寫入標題
j = 4
Do
i = 2
Do
d(ar(i, 2)) = ar(i, j) + d(ar(i, 2)) '以第2欄內容為字典索引，分別計算個索引加總
i = i + 1
Loop Until i > UBound(ar, 1) Or Cells(i, 1) = "" '直到列數大過表格列數或第1欄為空白
For Each ky In d.keys '取出每個字典索引
Ay(s) = d(ky)
s = s + 1
Next
Cells(i, j).Resize(3, 1) = Application.Transpose(Ay) '表格下方寫入加總資料
Erase Ay: s = 0: d.RemoveAll '清除陣列與字典內容
j = j + 1 '欄數加1
Loop Until j > UBound(ar, 2) Or TypeName(Cells(1, j).Value) = "String" '直到欄位大過表格欄位或是第一列的值是字串(避免第2次執行會計算到原本新增的統計位置)
Cells(i + 2, 4).Resize(, Range("A1").CurrentRegion.Columns.Count - 3) = "=R[-1]C-R[-2]C" '寫入加總值差額公式
Cells(i, 3) = "Sub_Add": Cells(i + 1, 3) = "Sub_None": Cells(i + 2, 3) = "Total" '寫入標題
End Sub

複製代碼