- 帖子
- 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
|
|
發表於 2013-4-26 16:55
| 
