　暱稱: jjjohn

帖子: 178
主題: 65
精華: 0
積分: 252
點名: 0
作業系統: WINDOW7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2010-5-4
最後登錄: 2024-2-1

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2010-6-5 12:21 | 只看該作者

[發問] VBA sum 問題

本帖最後由 john2006168 於 2010-6-5 12:23 編輯

Book2.zip (1.93 KB) 要做到好像sheet2,相同的ref no,sum of ctn and gw.其他不變
shee1

ref no ctn gw remark
john001 1 6 go
john002 2 2 go
john002 2 3 go
john002 1 2 go
john003 1 7 go
john004 1 8 go
john005 1 9 go
john006 1 10 go
john007 2 1 go
john007 2 1 go
john008 3 6 go
john009 4 7 go
john010 5 8 go

Sheet2
ref no ctn gw remark
john001 1 6 go
john002 5 7 go
john003 1 7 go
john004 1 8 go
john005 1 9 go
john006 1 10 go
john007 4 2 go
john008 3 6 go
john009 4 7 go
john010 5 8 go

樓主熱帖

Andy2483

　暱稱: 厚臉皮的學生

大學生 Rank: 4

帖子: 1447
主題: 40
精華: 0
積分: 1471
點名: 0
作業系統: Windows 7
軟體版本: Excel 2010 & 2016
閱讀權限: 50
性別: 男
來自: 台灣
註冊時間: 2020-7-15
最後登錄: 2024-12-5

8^#

發表於 2023-3-28 16:39 | 只看該作者

回復 2# Hsieh

謝謝前輩,謝謝論壇
後學藉此帖範例練習陣列與字典,學習的方案如下
請前輩們指教

執行前:

執行結果:

Option Explicit
Sub TEST()
Dim Brr, i&, N&, xR, Y, j&, B&, C&
Set Y = CreateObject("Scripting.Dictionary")
Set xR = Range([Sheet1!D1], [Sheet1!A65536].End(3))
Brr = xR
For i = 2 To UBound(Brr)
If Y(Brr(i, 1)) = "" Then
   Y(Brr(i, 1)) = Y.Count + 1: N = Y(Brr(i, 1))
   For j = 1 To UBound(Brr, 2): Brr(N, j) = Brr(i, j): Next
   Else
      N = Y(Brr(i, 1))
      For j = 2 To 3: Brr(N, j) = Brr(N, j) + Brr(i, j): Next
End If
B = B + Brr(i, 2): C = C + Brr(i, 3)
Next
With xR.Item(1, 14).Resize(Y.Count + 1, UBound(Brr, 2))
.EntireColumn.Clear: .Value = Brr: .Item(Y.Count + 2, 1) = "總計"
.Item(Y.Count + 2, 2) = B: .Item(Y.Count + 2, 3) = C
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub

用行動裝置瀏覽論壇學習很方便,謝謝論壇經營團隊
請大家一起上論壇來交流

TOP

victorl

中學生 Rank: 2

帖子: 65
主題: 0
精華: 0
積分: 120
點名: 0
作業系統: Win 7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
註冊時間: 2010-5-15
最後登錄: 2010-7-16

7^#

發表於 2010-6-8 00:33 | 只看該作者

原來不甚了解，拜讀 Hsieh大大的
http://forum.twbts.com/viewthread.php?tid=20
Dictionary物件介紹後，功力增強了不少；懇請 Hsieh大大多提供一些Object物件的介紹文章。

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 276
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-22

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

6^#

發表於 2010-6-7 00:41 | 只看該作者

回復 4# john2006168

If Not d.exists(a & a.Offset(, 3)) Then'假如字典物件找不到a & a.Offset(, 3)就是d.(a & a.Offset(, 3)) 還沒建立時

d(a & a.Offset(, 3)) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value)'就賦予d.(a & a.Offset(, 3)) 的內容為一陣列

Else'否則

ar = d(a & a.Offset(, 3))'取出d.(a & a.Offset(, 3))

ar(1) = ar(1) + a.Offset(, 1): ar(2) = ar(2) + a.Offset(, 2)'改變取出的陣列元素值

d(a & a.Offset(, 3)) = ar'存回改變後的陣列給d.(a & a.Offset(, 3))

學海無涯_不恥下問

TOP

wqfzqgk

中學生 Rank: 2

帖子: 75
主題: 19
精華: 0
積分: 135
點名: 0
作業系統: win7
軟體版本: 2007 010
閱讀權限: 20
註冊時間: 2010-5-18
最後登錄: 2013-10-26

5^#

發表於 2010-6-6 15:19 | 只看該作者

因为第三列不是数字，可以用合并计算去做也很快

学习

TOP

john2006168

　暱稱: jjjohn

中學生 Rank: 2

帖子: 178
主題: 65
精華: 0
積分: 252
點名: 0
作業系統: WINDOW7
軟體版本: Office 2010
閱讀權限: 20
性別: 男
來自: HK
註冊時間: 2010-5-4
最後登錄: 2024-2-1

4^#

發表於 2010-6-5 22:45 | 只看該作者

是的.用樞紐分析表最快,多謝老師指導.不過下面幾句不是很明白..盼說明

If Not d.exists(a & a.Offset(, 3)) Then

07.    d(a & a.Offset(, 3)) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value)

08.    Else

09.    ar = d(a & a.Offset(, 3))

10.    ar(1) = ar(1) + a.Offset(, 1): ar(2) = ar(2) + a.Offset(, 2)

11.    d(a & a.Offset(, 3)) = ar

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2010-6-5 16:17 | 只看該作者

使用陣列方式
Sub Ex()
Dim Ar(), M, E As Range, R
ReDim Preserve Ar(1 To 1)
Ar(1) = Array("ref no", "Sum of ctr", "Sum of gw", "remark")
M = Array(Ar(1)(0))
For Each E In Sheet1.Range("A2", Sheet1.[d65536].End(xlUp)).Rows
      R = Application.Match(E.Cells(1, 1).Value, M, 0)
      If IsNumeric(R) Then
         Ar(R)(1, 2) = Ar(R)(1, 2) + E.Cells(1, 2)
         Ar(R)(1, 3) = Ar(R)(1, 3) + E.Cells(1, 3)
      Else
         ReDim Preserve Ar(1 To UBound(Ar) + 1)
         Ar(UBound(Ar)) = E.Value
         M = Split(Join(M, ",") & "," & Ar(UBound(Ar))(1, 1), ",")
      End If
Next
Sheet2.Columns("A:D") = ""
Sheet2.[a1].Resize(UBound(Ar), 4).Value = Application.Transpose(Application.Transpose(Ar))
End Sub

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 276
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-12-22

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2010-6-5 14:35 | 只看該作者

回復 1# john2006168

樞紐分析表最快
若純粹討論VBA

Sub Ex()
Set d = CreateObject("Scripting.Dictionary")
d("ref no") = Array("ref no", "Sum of ctr", "Sum of gw", "remark")
With Sheet1
For Each a In .Range(.[A2], .[A65536].End(xlUp))
If Not d.exists(a & a.Offset(, 3)) Then
d(a & a.Offset(, 3)) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value)
Else
ar = d(a & a.Offset(, 3))
ar(1) = ar(1) + a.Offset(, 1): ar(2) = ar(2) + a.Offset(, 2)
d(a & a.Offset(, 3)) = ar
End If
Next
End With
Sheet2.Columns("A:D") = ""
Sheet2.[A1].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items))
End Sub

複製代碼

樞紐.zip (11.75 KB)

學海無涯_不恥下問

TOP