返回列表 上一主題 發帖

[發問] VBA sum 問題

[發問] 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

回復 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)
學海無涯_不恥下問

TOP

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

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

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

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

TOP

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

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

TOP

        靜思自在 : 看別人不順眼,是自己修養不夠。
返回列表 上一主題