[發問] 有關比對不同EXCEL表中資料的內容，藉以找出重複資料~

本帖最後由 jiunyanwu 於 2013-4-26 10:38 編輯

今天我有多個excel檔案
其中一個excel檔案，有一工作表名為「基準資料庫」
裡頭的內容為：
            阿貓
            阿狗
            阿猴
            阿豬
   .....
   .....
另一個檔案，有一個工作表，名為「比對組1」
裡頭內容為：
      代號       電話       資料
1    a             123       我是阿貓
2    b             456    我是阿熊
3    c             789    誰不是大豬
.....
...
其他excel檔案亦分別有工作表，名為「比對組2」、「比對組3」......等多個檔案

今天我要以「基準資料庫」為基準，來比對「比對組1」、比對組2、……，看裡頭內容是否有基準資料庫的資料
如果有的話，就將比對組的符合資料顯示出來。
(如上述範例，就有第一列的資料符合)

這樣要如何用vba來呈現呢？
小弟已經困擾好久了，不知是否有高手能為小弟解惑，謝謝！！

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

6^#

發表於 2013-4-29 17:06 | 只看該作者

回復 5# jiunyanwu
新增模組至基準資料庫 , 複製貼上代碼 , 存成xlsm

Sub Test()
Dim f, i, r
Dim arName() As String
Dim wb As Workbook
f = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*),*.xls*", Title:="選擇比對檔案", MultiSelect:=True)
If Not IsArray(f) Then Exit Sub
With Sheets("基準資料庫")
For Each it In .Range("A1:A4,B1:B2") '要篩選的字
If it <> "" Then
If i = 0 Then
ReDim arName(i)
Else
ReDim Preserve arName(i)
End If
arName(i) = "=""=*" & it & "*"""
i = i + 1
End If
Next
End With
Set wb = Workbooks.Add
With wb
With .Sheets(1)
.Name = "Criteria"
.[A1:C1] = Array("代號", "電話", "資料") 'Write Header
.[C2].Resize(UBound(arName)).Value = Application.Transpose(arName) 'Write Criteria
End With
.Sheets(2).Name = "篩選結果"
End With
r = 1
For Each it In f
With Workbooks.Open(it).Sheets(1)
'進階篩選
.Range("A1:C6").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=wb.Sheets(1).[A1].CurrentRegion, CopyToRange:=wb.Sheets(2).Range("A" & r), Unique:=False
.Parent.Close False
End With
With wb.Sheets(2)
If r > 1 Then .Rows(r).Delete xlShiftUp 'Delete Header
r = .Range("A" & .Rows.Count).End(xlUp).Row + 1
End With
Next
End Sub