[µo°Ý] VBA sum °ÝÃD

john2006168

Book2.zip (1.93 KB)

¤U¸ü¦¸¼Æ: 26

2010-6-5 12:23

­n°µ¨ì¦n¹³sheet2,¬Û¦Pªºref no,sum of ctn and gw.¨ä¥L¤£ÅÜ
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


    ¼Ï¯Ã¤ÀªRªí³Ì§Ö
­Y¯Âºé°Q½×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

½Æ»s¥N½X

¼Ï¯Ã.zip (11.75 KB)

¤U¸ü¦¸¼Æ: 17

2010-6-5 14:34

GBKEE

¨Ï¥Î°}¦C¤è¦¡
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

¬Oªº.¥Î¼Ï¯Ã¤ÀªRªí³Ì§Ö,¦hÁ¦Ѯv«ü¾É.¤£¹L¤U­±´X¥y¤£¬O«Ü©ú¥Õ..¬ß»¡©ú

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

¦]为²Ä¤T¦C¤£¬O数¦r¡A¥i¥H¥Î¦X¦}计ºâ¥h°µ¤]«Ü§Ö

Hsieh

¦^´_ 4# john2006168


If Not d.exists(a & a.Offset(, 3)) Then'°²¦p¦r¨åª«¥ó§ä¤£¨ìa & a.Offset(, 3)´N¬Od.(a & a.Offset(, 3)) ÁÙ¨S«Ø¥ß®É

d(a & a.Offset(, 3)) = Array(a.Value, a.Offset(, 1).Value, a.Offset(, 2).Value, a.Offset(, 3).Value)'´N½á¤©d.(a & a.Offset(, 3)) ªº¤º®e¬°¤@°}¦C

Else'§_«h

ar = d(a & a.Offset(, 3))'¨ú¥Xd.(a & a.Offset(, 3))

ar(1) = ar(1) + a.Offset(, 1): ar(2) = ar(2) + a.Offset(, 2)'§ïÅܨú¥Xªº°}¦C¤¸¯À­È

d(a & a.Offset(, 3)) = ar'¦s¦^§ïÅܫ᪺°}¦Cµ¹d.(a & a.Offset(, 3))

victorl

­ì¨Ó¤£¬Æ¤F¸Ñ¡A«ôŪ  Hsieh¤j¤jªº
http://forum.twbts.com/viewthread.php?tid=20
Dictionaryª«¥ó¤¶²Ð«á¡A¥\¤O¼W±j¤F¤£¤Ö¡FÀµ½Ð  Hsieh¤j¤j¦h´£¨Ñ¤@¨ÇObjectª«¥óªº¤¶²Ð¤å³¹¡C

Andy2483

¦^´_ 2# Hsieh


    ÁÂÁ«e½ú,ÁÂÁ½׾Â
«á¾ÇÂǦ¹©«½d¨Ò½m²ß°}¦C»P¦r¨å,¾Ç²ßªº¤è®×¦p¤U
½Ð«e½ú­Ì«ü±Ð

°õ¦æ«e:

¤U¸ü (86.33 KB)

2023-3-28 16:37

°õ¦æµ²ªG:

¤U¸ü (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) = "Á`­p"
   .Item(Y.Count + 2, 2) = B: .Item(Y.Count + 2, 3) = C
End With
Set Y = Nothing: Set xR = Nothing: Erase Brr
End Sub