[發問] VBA sum 問題

john2006168

Book2.zip (1.93 KB)

下載次數: 26

2010-6-5 12:23

要做到好像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

Hsieh

回復 1# john2006168


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

1. Sub Ex()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. d("ref no") = Array("ref no", "Sum of ctr", "Sum of gw", "remark")
   
4. With Sheet1
   
5. For Each a In .Range(.[A2], .[A65536].End(xlUp))
   
6.   If Not d.exists(a & a.Offset(, 3)) Then
   
7.      d(a & a.Offset(, 3)) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value)
   
8.      Else
   
9.      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
    
12.   End If
    
13. Next
    
14. End With
    
15. Sheet2.Columns("A:D") = ""
    
16. Sheet2.[A1].Resize(d.Count, 4) = Application.Transpose(Application.Transpose(d.items))
    
17. End Sub

複製代碼

樞紐.zip (11.75 KB)

下載次數: 17

2010-6-5 14:34

GBKEE

使用陣列方式
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

john2006168

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

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

wqfzqgk

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

Hsieh

回復 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))

victorl

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

Andy2483

回復 2# Hsieh


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

執行前:

下載 (86.33 KB)

2023-3-28 16:37

執行結果:

下載 (101.61 KB)

2023-3-28 16:37

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