[發問] 比較資料-利用VBA程式比較兩個資料檔案並做計算

amychlo

麻煩各位大大：
以下不知有誰會呢？可以教我嗎？
檔案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

回復 1# amychlo

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

1. Sub 彙整()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
   
4. 'fd="D:\"  '指定A、B2檔案的存放目錄
   
5. fs = Array("A.xls", "B.xls")
   
6. d("規格") = "數量"
   
7. For Each f In fs
   
8.    With Workbooks.Open(fd & f)
   
9.       With .Sheets(1)
   
10.       i = i + 1
    
11.       .UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
    
12.       With ThisWorkbook.Sheets(i)
    
13.           For Each a In .Range(.[A2], .[A2].End(xlDown))
    
14.              If IsEmpty(d(a.Value)) Then d(a.Value) = a.Offset(, 1) Else d(a.Value) = a.Offset(, 1) - d(a.Value)
    
15.           Next
    
16.       End With
    
17.       End With
    
18.       .Close
    
19.     End With
    
20. Next
    
21. With Sheets(3)
    
22.    .[A1].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
23.    .[B1].Resize(d.Count, 1) = Application.Transpose(d.items)
    
24. End With
    
25. End Sub

複製代碼

amychlo

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

kimbal

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

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

amychlo

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

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

1. Sub 彙整()
   
2. Dim Ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
   
5. 'fd="D:\"  '指定A、B2檔案的存放目錄
   
6. fs = Array("A.xls", "B.xls")
   
7. d("規格") = "數量"
   
8. For Each f In fs
   
9.    With Workbooks.Open(fd & f)
   
10.       With .Sheets(1)
    
11.       i = i + 1
    
12.       ReDim Preserve Ar(2, s)
    
13.       Ar(0, s) = "規格": Ar(1, s) = "數量"
    
14.       s = s + 1
    
15.       .UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
    
16.       With ThisWorkbook.Sheets(i)
    
17.           For Each a In .Range(.[B2], .[B2].End(xlDown))
    
18.              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))
    
19.              ReDim Preserve Ar(2, s)
    
20.              Ar(0, s) = Right(a, 2): Ar(1, s) = a.Offset(, IIf(i = 1, 3, 2)).Value
    
21.              s = s + 1
    
22.           Next
    
23.           Sheets(3).[A1].Offset(, (i - 1) * 2).Resize(s, 2) = Application.Transpose(Ar)
    
24.           Erase Ar: s = 0
    
25.       End With
    
26.       End With
    
27.       .Close
    
28.     End With
    
29. Next
    
30. With Sheets(3)
    
31.    .[E1].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
32.    .[F1].Resize(d.Count, 1) = Application.Transpose(d.items)
    
33. End With
    
34. End Sub

複製代碼

amychlo

回復 6# Hsieh

大大：
感恩您的回復！
但我試了幾天還是改不出我要的狀況，
所以現在就把我的原始檔壓縮上傳，
再麻煩您看看！
感恩！
A.rar (6.78 KB)

下載次數: 9

2013-3-16 19:14

      B.rar (4.78 KB)

下載次數: 8

2013-3-16 19:14

Hsieh

回復 7# amychlo
試試看

1. Sub 彙整()
   
2. Dim Ar()
   
3. Set d = CreateObject("Scripting.Dictionary")
   
4. fd = ThisWorkbook.Path & "\" '3個檔案放在同目錄中
   
5. 'fd="D:\"  '指定A、B2檔案的存放目錄
   
6. fs = Array("A.xls", "B.xls")
   
7. d("規格") = "數量"
   
8. For Each f In fs
   
9.    With Workbooks.Open(fd & f)
   
10.       With .Sheets(1)
    
11.       i = i + 1
    
12.       ReDim Preserve Ar(2, s)
    
13.       Ar(0, s) = "規格": Ar(1, s) = "數量"
    
14.       s = s + 1
    
15.       .UsedRange.Copy ThisWorkbook.Sheets(i).[A1]
    
16.       With ThisWorkbook.Sheets(i)
    
17.           For Each a In .Range(.[B2], .[B2].End(xlDown))
    
18.           mystr = Mid(a, 1 / (i / 2))
    
19.              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)
    
20.              ReDim Preserve Ar(2, s)
    
21.              Ar(0, s) = mystr: Ar(1, s) = a.Offset(, IIf(i = 1, 7, 2)).Value
    
22.              s = s + 1
    
23.           Next
    
24.           Sheets(3).[A1].Offset(, (i - 1) * 2).Resize(s, 2) = Application.Transpose(Ar)
    
25.           Erase Ar: s = 0
    
26.       End With
    
27.       End With
    
28.       .Close 0
    
29.     End With
    
30. Next
    
31. With Sheets(3)
    
32.    .[E1].Resize(d.Count, 1) = Application.Transpose(d.keys)
    
33.    .[F1].Resize(d.Count, 1) = Application.Transpose(d.items)
    
34. End With
    
35. End Sub

複製代碼

amychlo

回復 8# Hsieh

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

Hsieh

回復 9# amychlo

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