返回列表 上一主題 發帖

[發問] 請問VBA可以做到兩檔案比對後再產生另一檔案的比對結果嗎?

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2013-7-25 16:56 | 顯示全部帖子
回復 4# vocolboy
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As Object, i As Variant, S  As Variant
  4.     Set d = CreateObject("scripting.dictionary")
  5.     i = 1
  6.     With Workbooks("A.xls").Sheets(1)
  7.         Do While .Cells(i, "e") <> ""
  8.             d(.Cells(i, "e").Value) = .Cells(i, "A").Value
  9.             i = i + 1
  10.         Loop
  11.     End With
  12.      i = 1
  13.     With Workbooks("B.xls").Sheets(1)
  14.         Do While .Cells(i, "J") <> ""
  15.            S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
  16.            If d.Exists(.Cells(i, "J").Value) Then
  17.                 S = S & "," & d(.Cells(i, "J").Value)
  18.                 d(.Cells(i, "J").Value) = Split(S, ",")
  19.            Else
  20.                 d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
  21.                 S = d(.Cells(i, "J").Value)
  22.            
  23.            End If
  24.             i = i + 1
  25.         Loop
  26.     End With
  27.     For Each i In d.keys
  28.         If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i        '可忽略"-"的步驟
  29.     Next
  30.     With Workbooks("C.xls").Sheets(1)
  31.         .Cells.Clear
  32.         S = Application.Transpose(Application.Transpose(d.ITEMS))
  33.         .[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
  34.     End With
  35. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2013-7-25 19:24 | 顯示全部帖子
回復 7# happycoccolin
xls 是2003版活頁簿的副檔名
2007版以後的副檔名xlsx是沒有巨集的活頁簿 ,副檔名xlsm是有巨集的活頁簿.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2013-7-26 13:47 | 顯示全部帖子
回復 9# happycoccolin
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As Object, i As Variant, S  As Variant, Wb As Workbook
  4.     Set d = CreateObject("scripting.dictionary")
  5.     With Application.FileDialog(msoFileDialogFilePicker) 'FileDialog :表檔案對話方, msoFileDialogFilePicker(參數):選取檔案
  6.         .AllowMultiSelect = False                        '允許使用者從檔案對話方塊選取多個檔案=False
  7.          If .Show = False Then MsgBox "沒有選擇檔案 !!!":   Exit Sub
  8.          Set Wb = Workbooks.Open(.SelectedItems(1))   '開啟指定檔案
  9.     End With
  10.     i = 1
  11.     With Workbooks("A.xlsx").Sheets(1)   '
  12.         Do While .Cells(i, "e") <> ""
  13.             d(.Cells(i, "e").Value) = .Cells(i, "A").Value
  14.             i = i + 1
  15.         Loop
  16.     End With
  17.      i = 1
  18.     With Wb.Sheets(1)
  19.         Do While .Cells(i, "J") <> ""
  20.            S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
  21.            If d.Exists(.Cells(i, "J").Value) Then
  22.                 S = S & "," & d(.Cells(i, "J").Value)
  23.                 d(.Cells(i, "J").Value) = Split(S, ",")
  24.            Else
  25.                 d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
  26.                 S = d(.Cells(i, "J").Value)
  27.            
  28.            End If
  29.             i = i + 1
  30.         Loop
  31.         .Parent.Close False               '關閉指定檔案不存檔
  32.     End With
  33.    
  34.     For Each i In d.keys
  35.         If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i        '可忽略"-"的步驟
  36.     Next
  37.     With Workbooks("C.xlsx").Sheets(1)
  38.         .Cells.Clear
  39.         S = Application.Transpose(Application.Transpose(d.ITEMS))
  40.         .[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
  41.     End With
  42. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2013-7-26 14:38 | 顯示全部帖子
本帖最後由 GBKEE 於 2013-7-26 17:05 編輯

回復 11# happycoccolin
  1. Option Explicit
  2. Sub Ex()
  3.     Dim d As Object, i As Variant, S  As Variant, Wb As Workbook, Wb_Name As String
  4.     Set d = CreateObject("scripting.dictionary")
  5.     With Application.FileDialog(msoFileDialogFilePicker) 'FileDialog :表檔案對話方, msoFileDialogFilePicker(參數):選取檔案
  6.         .AllowMultiSelect = False                        '允許使用者從檔案對話方塊選取多個檔案=False
  7.          If .Show = False Then MsgBox "沒有選擇檔案 !!!":   Exit Sub
  8.          Set Wb = Workbooks.Open(.SelectedItems(1))   '開啟指定檔案
  9.     End With
  10.     i = 1
  11.     With Workbooks("A.xlsx").Sheets(1)   '
  12.         Do While .Cells(i, "e") <> ""
  13.             d(.Cells(i, "e").Value) = .Cells(i, "A").Value
  14.             i = i + 1
  15.         Loop
  16.     End With
  17.      i = 1
  18.     With Wb.Sheets(1)
  19.         Do While .Cells(i, "J") <> ""
  20.            S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
  21.            If d.Exists(.Cells(i, "J").Value) Then
  22.                 S = S & "," & d(.Cells(i, "J").Value)
  23.                 d(.Cells(i, "J").Value) = Split(S, ",")
  24.            Else
  25.                 d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
  26.                 S = d(.Cells(i, "J").Value)
  27.            
  28.            End If
  29.             i = i + 1
  30.         Loop
  31.         .Parent.Close False               '關閉指定檔案不存檔
  32.     End With
  33.     For Each i In d.keys
  34.         If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i        '可忽略"-"的步驟
  35.     Next
  36.     Do
  37.         Wb_Name = InputBox("輸入新檔名", "存檔名稱")
  38.     Loop Until Wb_Name <> ""                             '直到有輸入字串離開迴圈
  39.     Set Wb = Workbooks.Add(1)
  40.     With Wb.Sheets(1)
  41.         .Cells.Clear
  42.         S = Application.Transpose(Application.Transpose(d.ITEMS))
  43.         .[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
  44.     End With
  45.     Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX"  '存檔的完整名稱
  46. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2013-7-26 15:27 | 顯示全部帖子
回復 13# happycoccolin
同一個模組中 不能有相同的程序名稱  Sub Ex()
找找看還有第2個 Sub Ex() 嗎?
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
6#
發表於 2013-7-26 17:03 | 顯示全部帖子
回復 15# happycoccolin
不好意思 改一下最後 Save -> SaveAs
  1. Wb.SaveAs "D:\TEST\" & Wb_Name & "XLSX"  '存檔的完整名稱
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2013-7-26 19:58 | 顯示全部帖子
回復 17# happycoccolin
因為我已經將資料庫放在ABC.xlsm裡面了
    With Workbooks("A.xlsx").Sheets(1)   -改一下檔名  With Workbooks("ABC.xlsm").Sheets(1)
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
8#
發表於 2013-7-30 14:43 | 顯示全部帖子
回復 19# happycoccolin
可是比對結果通通都是NO DATA
問題在這裡
  1. With Workbooks("ABC.xlsm").Sheets(1)
  2.         '這Sheets(1) 是ABC.xlsm的第一個工作表 (MAIN)
  3.         '是否要改成 Sheets(2) ->  第二個工作表 (A)
  4.         Do While .Cells(i, "e") <> ""
  5.             d(.Cells(i, "e").Value) = .Cells(i, "A").Value
  6.             i = i + 1
  7.         Loop
  8.     End With
複製代碼
D:\TEST \  這資料夾是我隨意寫的,你需改為你PC中存在的資料夾
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 慈悲沒有敵人，智慧不起煩惱。
返回列表 上一主題