請問VBA可以做到兩檔案比對後再產生另一檔案的比對結果嗎? - Excel程式區

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

7^# 跳轉到 »

發表於 2013-7-25 18:20 | 只看該作者

回復 6# GBKEE

謝謝版大~~~

抱歉小妹才疏學淺......

請問一下要怎麼使用才能做比對呢?

我將語法複製到模組中但是如何才能正確使用?

目前偵錯停在
With Workbooks("A.xls").Sheets(1)

對VBA很有興趣但是未開竅目前腳步很慢尚停留在函數階段也請各位大師們多多見諒我問的笨問題..

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 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-25 16:56 | 只看該作者

回復 4# vocolboy

Option Explicit
Sub Ex()
Dim d As Object, i As Variant, S As Variant
Set d = CreateObject("scripting.dictionary")
i = 1
With Workbooks("A.xls").Sheets(1)
Do While .Cells(i, "e") <> ""
d(.Cells(i, "e").Value) = .Cells(i, "A").Value
i = i + 1
Loop
End With
i = 1
With Workbooks("B.xls").Sheets(1)
Do While .Cells(i, "J") <> ""
S = Join(Application.Transpose(Application.Transpose(.Range("A" & i & ":J" & i))), ",")
If d.Exists(.Cells(i, "J").Value) Then
S = S & "," & d(.Cells(i, "J").Value)
d(.Cells(i, "J").Value) = Split(S, ",")
Else
d(.Cells(i, "J").Value) = Split(S & ",No Data", ",")
S = d(.Cells(i, "J").Value)
End If
i = i + 1
Loop
End With
For Each i In d.keys
If InStr(i, "-") Then If Mid(i, InStr(i, "-"), 2) <> "-1" Then d.Remove i '可忽略"-"的步驟
Next
With Workbooks("C.xls").Sheets(1)
.Cells.Clear
S = Application.Transpose(Application.Transpose(d.ITEMS))
.[A1].Resize(UBound(S, 1), UBound(S, 2)) = S
End With
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

TOP

happycoccolin

　暱稱: NANAKO

中學生 Rank: 2

帖子: 72
主題: 7
精華: 0
積分: 88
點名: 0
作業系統: Windows 7
軟體版本: Office 2007
閱讀權限: 20
性別: 女
註冊時間: 2012-6-28
最後登錄: 2018-11-14

5^#

發表於 2013-7-25 16:14 | 只看該作者

回復 4# vocolboy

哈囉~~謝謝vocolboy ~

請問一下是否可以有一個檔案開啟以後讓我按鈕選擇載入兩個檔案比對呢?

例如

按鈕一  請選擇檔案
按鈕二  請選擇檔案
按鈕三  開始比對

TOP

vocolboy

小學生 Rank: 1

帖子: 2
主題: 1
精華: 0
積分: 21
點名: 0
作業系統: xp
軟體版本: office2003
閱讀權限: 10
性別: 男
註冊時間: 2013-7-18
最後登錄: 2018-5-22

4^#

發表於 2013-7-25 14:47 | 只看該作者

本帖最後由 vocolboy 於 2013-7-25 14:48 編輯

回復 1# happycoccolin

我也是剛學的不能下載付件直接從你上述的寫

Sub 比對()
Set d = CreateObject("Scripting.Dictionary")       '字典
With Workbooks("A.xls").Sheets(1)                      'with 報名名稱.工作表名稱
  For Each a In .Range(.[E2], .[E65536].End(xlUp))
d(a & "") = Array(a.Offset(, -4).Value)
  Next
End With
With Workbooks("B.xls").Sheets(1)
  For Each a In .Range(.[J2], .[J65536].End(xlUp))
a.Offset(, 1).Resize(, 1).Value = d(a & "")
  Next
End With
End Sub

這個結果並不會產生到C新的上
他會match在B裡面
我想這只是個複製貼上小問題@@

TOP

happycoccolin