麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何用VBA將SHEET1內相同的資料合併計算後複製到SHEET2 [打印本頁]

作者: bear0925900003 時間: 2013-7-24 18:00 標題: 如何用VBA將SHEET1內相同的資料合併計算後複製到SHEET2

如何用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 時間: 2013-7-24 20:35

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

作者: GBKEE 時間: 2013-7-25 06:55

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

Option Explicit
Sub Ex()
Dim D As Object, i As Integer, A
Set D = CreateObject("SCRIPTING.DICTIONARY")
With Sheets("SHEET1") ''工作表物件
i = 1
Do While .Cells(i, "A") <> "" '工作表.物件加. 為此物件的子物件,方法,屬性
'Do While .Range("A" & i) <> "" '也可以用 Range
D(.Cells(i, "A").Value) = D(.Cells(i, "A").Value) + .Cells(i, "B")
i = i + 1
Loop
End With
If i > 1 Then
With Sheets("SHEET2")
.[A1].Resize(D.Count) = Application.Transpose(D.KEYS)
.[B1].Resize(D.Count) = Application.Transpose(D.ITEMS)
End With
End If
End Sub

複製代碼

作者: bear0925900003 時間: 2013-7-26 14:41

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

作者: bear0925900003 時間: 2013-8-3 10:13

回復 3# GBKEE

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

作者: GBKEE 時間: 2013-8-3 17:27

回復 5# bear0925900003

Option Explicit
Sub Ex()
Dim D As Object, i As Integer
Set D = CreateObject("SCRIPTING.DICTIONARY")
With Sheets("SHEET1") ''工作表物件
i = 1
Do While .Cells(i, "A") <> "" '工作表.物件加. 為此物件的子物件,方法,屬性
'Do While .Range("A" & i) <> "" '也可以用 Range
D(.Cells(i, "A").Value) = D(.Cells(i, "A").Value) + .Cells(i, "B")
i = i + 1
Loop
End With
With Sheets("SHEET2") ''工作表物件
i = 1
Do While .Cells(i, "A") <> "" '工作表.物件加. 為此物件的子物件,方法,屬性
'Do While .Range("A" & i) <> "" '也可以用 Range
D(.Cells(i, "A").Value) = D(.Cells(i, "A").Value) + .Cells(i, "B")
i = i + 1
Loop
End With
If D.Count > 1 Then
With Sheets("SHEET3")
.[A1].Resize(D.Count) = Application.Transpose(D.KEYS)
.[B1].Resize(D.Count) = Application.Transpose(D.ITEMS)
End With
End If
End Sub

複製代碼

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

複製代碼

作者: bear0925900003 時間: 2013-8-3 17:51

回復 6# GBKEE

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

作者: bear0925900003 時間: 2013-8-9 16:55

回復 3# GBKEE

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

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

作者: GBKEE 時間: 2013-8-10 14:23

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

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)