12
返回列表 上一主題 發帖

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

amychlo

帖子
9 
主題
2 
精華
0 
積分
50 
點名
0  
作業系統
XP 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-2-22 
最後登錄
2015-5-14 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 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

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
247  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-14 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 2013-2-22 22:33 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

amychlo

帖子
9 
主題
2 
精華
0 
積分
50 
點名
0  
作業系統
XP 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-2-22 
最後登錄
2015-5-14 
3#
發表於 2013-2-23 19:35 | 只看該作者
大大請問一下：
1.您所說的一般模組是在Module下嗎？
2.放在模組下，不用建按鈕觸發嗎？
不好意思！
因為剛接觸vba所以一切還在摸索中，
請您多多指教囉！
感恩

TOP

kimbal

帖子
472 
主題
5 
精華
0 
積分
485 
點名
0  
作業系統
Windows 
軟體版本
MS Office 
閱讀權限
100 
性別
男 
來自
香港 
註冊時間
2010-7-4 
最後登錄
2014-12-28 

論壇貢獻勳章
4#
發表於 2013-2-28 13:46 | 只看該作者
大大請問一下：
1.您所說的一般模組是在Module下嗎？
2.放在模組下，不用建按鈕觸發嗎？
不好意思！
因 ...
amychlo 發表於 2013-2-23 19:35


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

今日の一秒は  明日にない
http://kimbalko-chi.blogspot.com
http://kimbalko.blogspot.com

TOP

amychlo

帖子
9 
主題
2 
精華
0 
積分
50 
點名
0  
作業系統
XP 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-2-22 
最後登錄
2015-5-14 
5#
發表於 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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
247  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-14 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
6#
發表於 2013-3-7 21:07 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

amychlo

帖子
9 
主題
2 
精華
0 
積分
50 
點名
0  
作業系統
XP 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-2-22 
最後登錄
2015-5-14 
7#
發表於 2013-3-16 19:14 | 只看該作者
回復 6# Hsieh

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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
247  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-14 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
8#
發表於 2013-3-16 22:56 | 只看該作者
回復 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
複製代碼
學海無涯_不恥下問

TOP

amychlo

帖子
9 
主題
2 
精華
0 
積分
50 
點名
0  
作業系統
XP 
軟體版本
Office 2007 
閱讀權限
20 
性別
女 
註冊時間
2013-2-22 
最後登錄
2015-5-14 
9#
發表於 2013-3-18 20:49 | 只看該作者
回復 8# Hsieh

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

TOP

Hsieh

帖子
4901 
主題
44 
精華
24 
積分
4916 
點名
247  
作業系統
Windows 7 
軟體版本
Office 20xx 
閱讀權限
150 
性別
男 
來自
台北 
註冊時間
2010-4-30 
最後登錄
2024-11-14 

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
10#
發表於 2013-3-18 23:06 | 只看該作者
回復 9# amychlo

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

TOP

        靜思自在 : 唯其尊重自己的人，才更勇於縮小自己。
12
返回列表 上一主題