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

標題: [發問] 比較資料-利用VBA程式比較兩個資料檔案並做計算 [打印本頁]

作者: amychlo 時間: 2013-2-22 21:34 標題: 比較資料-利用VBA程式比較兩個資料檔案並做計算

麻煩各位大大：
以下不知有誰會呢？可以教我嗎？
檔案A
規格  數量
AAA  20
BBB 35
CCC  42
DDD 10
檔案B
規格  數量
AAA  20
BBB 30
CCC  46
DDD 10
就是有兩個檔案內容分別如上，希望能夠按一個按鈕，
1.先將兩個檔案分別放在同一檔案不同的工作表
2.再將比較結果放在第三個工作表，顯示如下：
規格  數量規格  數量規格  差異數
AAA  20    AAA  20    AAA    0
BBB 30    BBB 35    BBB       5  (儲存格用紅色顯示)
CCC  42    CCC  46    CCC    -6  (儲存格用紅色顯示)
DDD 10    DDD 10    DDD    0

作者: Hsieh 時間: 2013-2-22 22:33

回復 1# amychlo

將程式碼放在彙整的活頁簿一般模組

Sub 彙整()
Set d = CreateObject("Scripting.Dictionary")
fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
'fd="D:\" '指定A、B2檔案的存放目錄
fs = Array("A.xls", "B.xls")
d("規格") = "數量"
For Each f In fs
With Workbooks.Open(fd & f)
With .Sheets(1)
i = i + 1
.UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
With ThisWorkbook.Sheets(i)
For Each a In .Range(.[A2], .[A2].End(xlDown))
If IsEmpty(d(a.Value)) Then d(a.Value) = a.Offset(, 1) Else d(a.Value) = a.Offset(, 1) - d(a.Value)
Next
End With
End With
.Close
End With
Next
With Sheets(3)
.[A1].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[B1].Resize(d.Count, 1) = Application.Transpose(d.items)
End With
End Sub

複製代碼

作者: amychlo 時間: 2013-2-23 19:35

大大請問一下：
1.您所說的一般模組是在Module下嗎？
2.放在模組下，不用建按鈕觸發嗎？
不好意思！
因為剛接觸vba所以一切還在摸索中，
請您多多指教囉！
感恩

作者: kimbal 時間: 2013-2-28 13:46

大大請問一下：
1.您所說的一般模組是在Module下嗎？
2.放在模組下，不用建按鈕觸發嗎？
不好意思！
因 ...
amychlo 發表於 2013-2-23 19:35

1. 對
2.不建按鈕的話,
在module上點上任何一行, 按keyboard "F5"鍵可
或在excel頁面 "開發人員"菜單->巨集->選上sub ->執行

作者: amychlo 時間: 2013-3-7 19:50

回復 2# Hsieh

感恩大大的回應！
(3/2)後來提問的問題是：
A.xls
項次  規格  單位  單價  數量
1    AA1 pcs 10 300
2    AB2 pcs    20 35
3    AC1 pcs    18 0
4    AD2 pcs    10 52
5    AE3 pcs    15 200
B.xls
項次  規格  單位  數量
1    A1    pcs 300
2    B2    pcs    40
3    E3    pcs    150
1.首先先將A、B兩個檔案分別放在同一個檔案、不同的工作表
A、B兩個檔案的[規格]是相同的，
只是當初在建A檔案時在每一個規格的第一碼加了一碼"A"，
其餘後方的都相同。
2.再將比較結果放在第三個工作表，顯示如下：
(希望在第三個工作表也能將A、B兩檔案顯示出來)
規格  數量規格  數量    規格  差異數(B.xla-A.xls)
A1    300    A1    300    A1    0
B2    35       B2    40       B2    5
C1    0       E3    150    C1    0
D2 52                               D2    -52
E3    200                            E3    -50

作者: Hsieh 時間: 2013-3-7 21:07

回復 5# amychlo
昨天因為論壇的磁碟陣列出問題，遺失了資料，重新回復

Sub 彙整()
Dim Ar()
Set d = CreateObject("Scripting.Dictionary")
fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
'fd="D:\" '指定A、B2檔案的存放目錄
fs = Array("A.xls", "B.xls")
d("規格") = "數量"
For Each f In fs
With Workbooks.Open(fd & f)
With .Sheets(1)
i = i + 1
ReDim Preserve Ar(2, s)
Ar(0, s) = "規格": Ar(1, s) = "數量"
s = s + 1
.UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
With ThisWorkbook.Sheets(i)
For Each a In .Range(.[B2], .[B2].End(xlDown))
If IsEmpty(d(Right(a, 2))) Then d(Right(a, 2)) = a.Offset(, IIf(i = 1, 3, 2)) Else d(Right(a, 2)) = a.Offset(, IIf(i = 1, 3, 2)) - d(Right(a, 2))
ReDim Preserve Ar(2, s)
Ar(0, s) = Right(a, 2): Ar(1, s) = a.Offset(, IIf(i = 1, 3, 2)).Value
s = s + 1
Next
Sheets(3).[A1].Offset(, (i - 1) * 2).Resize(s, 2) = Application.Transpose(Ar)
Erase Ar: s = 0
End With
End With
.Close
End With
Next
With Sheets(3)
.[E1].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[F1].Resize(d.Count, 1) = Application.Transpose(d.items)
End With
End Sub

複製代碼

作者: amychlo 時間: 2013-3-16 19:14

回復 6# Hsieh

大大：
感恩您的回復！
但我試了幾天還是改不出我要的狀況，
所以現在就把我的原始檔壓縮上傳，
再麻煩您看看！
感恩！
[attach]14378[/attach] [attach]14379[/attach]

作者: Hsieh 時間: 2013-3-16 22:56

回復 7# amychlo
試試看

Sub 彙整()
Dim Ar()
Set d = CreateObject("Scripting.Dictionary")
fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
'fd="D:\" '指定A、B2檔案的存放目錄
fs = Array("A.xls", "B.xls")
d("規格") = "數量"
For Each f In fs
With Workbooks.Open(fd & f)
With .Sheets(1)
i = i + 1
ReDim Preserve Ar(2, s)
Ar(0, s) = "規格": Ar(1, s) = "數量"
s = s + 1
.UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
With ThisWorkbook.Sheets(i)
For Each a In .Range(.[B2], .[B2].End(xlDown))
mystr = Mid(a, 1 / (i / 2))
If IsEmpty(d(mystr)) Then d(mystr) = a.Offset(, IIf(i = 1, 7, 2)) Else d(mystr) = a.Offset(, IIf(i = 1, 7, 2)) - d(mystr)
ReDim Preserve Ar(2, s)
Ar(0, s) = mystr: Ar(1, s) = a.Offset(, IIf(i = 1, 7, 2)).Value
s = s + 1
Next
Sheets(3).[A1].Offset(, (i - 1) * 2).Resize(s, 2) = Application.Transpose(Ar)
Erase Ar: s = 0
End With
End With
.Close 0
End With
Next
With Sheets(3)
.[E1].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[F1].Resize(d.Count, 1) = Application.Transpose(d.items)
End With
End Sub

複製代碼

作者: amychlo 時間: 2013-3-18 20:49

回復 8# Hsieh

大大：感恩您！
大致上是可以了，
但是執行時發生
[執行階段錯誤'9'
陣列索引超出範圍]
再按(偵錯)後
就發現模組程式指向第24列，
所以不知道這一列是有什麼用途呢？
麻煩您囉！感恩

作者: Hsieh 時間: 2013-3-18 23:06

回復 9# amychlo

這句是將陣列寫入工作表
此句會發生超出陣列索引錯誤只可能發生在Sheets(3)
有可能你的活頁簿並沒有3個以上的工作表存在

作者: amychlo 時間: 2013-3-19 10:55

回復 10# Hsieh
大大：
我的工作表是剛好只有三張工作表，
沒有第四張。

作者: Hsieh 時間: 2013-3-19 10:57

本帖最後由 Hsieh 於 2013-3-19 11:01 編輯

回復 11# amychlo

這樣就很難判斷錯誤出在哪裡
加入底下紅字部分看看
如果還不行最好將3檔案上傳測試看看
Sub 彙整()
Dim Ar()
Set d = CreateObject("Scripting.Dictionary")
fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
'fd="D:\"  '指定A、B2檔案的存放目錄
fs = Array("A.xls", "B.xls")
d("規格") = "數量"
For Each f In fs
With Workbooks.Open(fd & f)
   With .Sheets(1)
   i = i + 1
   ReDim Preserve Ar(2, s)
   Ar(0, s) = "規格": Ar(1, s) = "數量"
   s = s + 1
   .UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
   With ThisWorkbook.Sheets(i)
      For Each a In .Range(.[B2], .[B2].End(xlDown))
      mystr = Mid(a, 1 / (i / 2))
         If IsEmpty(d(mystr)) Then d(mystr) = a.Offset(, IIf(i = 1, 7, 2)) Else d(mystr) = a.Offset(, IIf(i = 1, 7, 2)) - d(mystr)
         ReDim Preserve Ar(2, s)
         Ar(0, s) = mystr: Ar(1, s) = a.Offset(, IIf(i = 1, 7, 2)).Value
         s = s + 1
      Next
      ThisWorkbook.Sheets(3).[A1].Offset(, (i - 1) * 2).Resize(s, 2) = Application.Transpose(Ar)
      Erase Ar: s = 0
   End With
   End With
   .Close 0
End With
Next
With Sheets(3)
.[E1].Resize(d.Count, 1) = Application.Transpose(d.keys)
.[F1].Resize(d.Count, 1) = Application.Transpose(d.items)
End With
End Sub

作者: amychlo 時間: 2013-3-19 19:54

回復 12# Hsieh
大大：感恩你！
目前測試成功。
就如你所加的一樣，OK了！

作者: Hsieh 時間: 2013-3-20 08:45

回復 13# amychlo
這原因就出現在因為開啟來源檔案後作用視窗變成來源檔案
未指定活頁簿的工作表就會指向該做用中活頁簿
所以當A或B檔案沒有第3張工作表時即會出現此錯誤

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