- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
回復 13# 假面超人 - Option Explicit
- Sub Ex() '有多於2個以上的工作表要篩選
- Dim Rng(1 To 3) As Range, a As Integer, Sh_Count As Integer
- Sh_Count = Sheets.Count '此活頁簿中工作表的總數
- Set Rng(1) = Sheets(1).Range("a1").CurrentRegion '進階篩選: 準則範圍 取得為 Sheet1[A1:A3]
- 'Set Rng(2) = Sheets("最終結果").Range("A1").CurrentRegion '改為此活頁簿中最後的工作表
- Set Rng(2) = Sheets(Sh_Count).Range("A1").CurrentRegion
- Rng(2) = "" '清理先前篩選的資料
- Rng(1).Rows(1).Copy Rng(2).Cells(1) '複製 準則的欄位
- For a = 2 To Sheets.Count - 1
- Sheets(a).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
- Set Rng(2) = Rng(2).Cells(1).End(xlDown).Offset(1) '複製到目的範圍 往下移動
- If a <> Sheets.Count - 1 Then Rng(1).Rows(1).Copy Rng(2).Cells(1)
- If Rng(3) Is Nothing Then '紀錄複製第2個工作表以後的複製到目的範圍欄位 第一列位置
- Set Rng(3) = Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
- Else
- Set Rng(3) = Union(Rng(3), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count))
- End If
- Next
- If Not Rng(3) Is Nothing Then Rng(3).Delete xlUp '刪除 紀錄複製第2個工作表以後的複製到目的範圍欄位 第一列位置
- End Sub
|
|
發表於 2012-8-2 07:01
| 
