有關比對不同EXCEL表中資料的內容，藉以找出重複資料~ - Excel程式區

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

1^# 跳轉到 »

發表於 2013-4-26 13:30 | 顯示全部帖子

回復 1# jiunyanwu
比對組是不同檔案名稱還是不同工作表名稱?
不同比對組的資料都是同一欄嗎? 是哪一欄?
附上檔案做例子會比較好解決~

2^#

發表於 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

複製代碼

靜思自在 : 得理要饒人，理直要氣和。