[發問] 如何用VBA將SHEET1內相同的資料合併計算後複製到SHEET2

bear0925900003

如何用VBA將SHEET1內相同的資料合併計算後複製到SHEET2，並依序排列：
例如：SHEET1內的
A1為摘要：代管費收入，B1為金額：10000
A2為摘要：磁扣收入：B2：為金額500
A3為摘要：代管費收入，B3為金額：1500
A4為摘要：磁扣收入：B4：為金額500

希望在SHEET1輸入完畢後，在SHEET2能自動整合為
A1為摘要：代管費收入，B1為金額：11500( 合併SHEET1的摘要，並加總)
A2為摘要：磁扣收入：B2：為金額1000()( 合併SHEET1的摘要，並加總)

煩請大大解惑，不勝感激.....
煩請附帶告知解惑之程式要貼在SHEET1還是SHEET2還是模組還是WORKBOOK裡

stillfish00

回復 1# bear0925900003
不用VBA的話，可以直接輸入公式就會幫你計算了，
在Sheet2的    B1輸入   =SUM(Sheet1!B1,Sheet1!B3)
                           B2輸入   =SUM(Sheet1!B2,Sheet1!B4)

GBKEE

回復 1# bear0925900003
物件有指明父層 程式碼可任意擺

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, i As Integer, A
   
4.     Set D = CreateObject("SCRIPTING.DICTIONARY")
   
5.     With Sheets("SHEET1")                                         ''工作表物件
   
6.         i = 1
   
7.         Do While .Cells(i, "A") <> ""                               '工作表.物件  加. 為此物件的 子物件,方法,屬性
   
8.              'Do While .Range("A" & i) <> ""    '也可以用 Range
   
9.             D(.Cells(i, "A").Value) = D(.Cells(i, "A").Value) + .Cells(i, "B")
   
10.             i = i + 1
    
11.         Loop
    
12.     End With
    
13.     If i > 1 Then
    
14.         With Sheets("SHEET2")
    
15.             .[A1].Resize(D.Count) = Application.Transpose(D.KEYS)
    
16.             .[B1].Resize(D.Count) = Application.Transpose(D.ITEMS)
    
17.         End With
    
18.     End If
    
19. End Sub

複製代碼

bear0925900003

感謝大大無私的分享，問題已解決，無盡感恩!!

bear0925900003

回復 3# GBKEE


   請問老師若要改成SHEET1、SHEET2合併到SHEET3該如何修改

GBKEE

回復 5# bear0925900003

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim D As Object, i As Integer
   
4.     Set D = CreateObject("SCRIPTING.DICTIONARY")
   
5.     With Sheets("SHEET1")                                         ''工作表物件
   
6.         i = 1
   
7.         Do While .Cells(i, "A") <> ""                               '工作表.物件  加. 為此物件的 子物件,方法,屬性
   
8.              'Do While .Range("A" & i) <> ""    '也可以用 Range
   
9.             D(.Cells(i, "A").Value) = D(.Cells(i, "A").Value) + .Cells(i, "B")
   
10.             i = i + 1
    
11.         Loop
    
12.     End With
    
13.     With Sheets("SHEET2")                                         ''工作表物件
    
14.         i = 1
    
15.         Do While .Cells(i, "A") <> ""                               '工作表.物件  加. 為此物件的 子物件,方法,屬性
    
16.              'Do While .Range("A" & i) <> ""    '也可以用 Range
    
17.             D(.Cells(i, "A").Value) = D(.Cells(i, "A").Value) + .Cells(i, "B")
    
18.             i = i + 1
    
19.         Loop
    
20.     End With
    
21.     If D.Count > 1 Then
    
22.         With Sheets("SHEET3")
    
23.             .[A1].Resize(D.Count) = Application.Transpose(D.KEYS)
    
24.             .[B1].Resize(D.Count) = Application.Transpose(D.ITEMS)
    
25.         End With
    
26.     End If
    
27. End Sub

複製代碼

1. Sub Ex_a()
   
2.     Dim D As Object, i As Integer, e As Variant
   
3.     Set D = CreateObject("SCRIPTING.DICTIONARY")
   
4.     For Each e In Array(Sheets("SHEET1"), Sheets("SHEET2"), Sheets("SHEET3"))
   
5.         With e
   
6.             i = 1
   
7.             Do While .Cells(i, "A") <> ""                              '工作表.物件  加. 為此物件的 子物件,方法,屬性
   
8.                  'Do While .Range("A" & i) <> ""    '也可以用 Range
   
9.                 D(.Cells(i, "A").Value) = D(.Cells(i, "A").Value) + .Cells(i, "B")
   
10.                 i = i + 1
    
11.             Loop
    
12.         End With
    
13.     Next
    
14.    If D.Count > 1 Then
    
15.         With Sheets("SHEET4")
    
16.             .[A1].Resize(D.Count) = Application.Transpose(D.KEYS)
    
17.             .[B1].Resize(D.Count) = Application.Transpose(D.ITEMS)
    
18.         End With
    
19.     End If
    
20. End Sub

複製代碼

bear0925900003

回復 6# GBKEE


    原來是這樣,董了,謝謝老師

bear0925900003

回復 3# GBKEE


    請問老師，您給的程式是無限的往下篩選複製，現有幾個疑問想請教：
1.如果只是要固定範圍的寫法(EX：A1~B10這個範圍)，那該如何修正本程式
2.如果為多頁且固定範圍的語法又該如何修正(EX:sheets1，sheets2的A1~B10合併複製到sheet3的B1~C10)

小弟試了多次始終無法修改成功，還請賜教，無限感激

GBKEE

回復 8# bear0925900003
用資料->合併彙算的指令 試試看