GBKEE

回復 9# 假面超人
依據你的檔案 寫下進階篩選的程式

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng(1 To 2) As Range
   
4.     Set Rng(1) = Sheet1.Range("a1").CurrentRegion   '進階篩選: 準則範圍  取得為 Sheet1[A1:A3]
   
5.     Set Rng(2) = Sheets("最終結果").Range("A1").CurrentRegion
   
6.     Rng(2) = ""                                     '清理先前篩選的資料
   
7.     Rng(1).Rows(1).Copy Rng(2).Cells(1)             '複製 準則的欄位
   
8.     '試試看將上一行程式碼註解不執行看看
   
9.     '進階篩選 : 複製到目的範圍 第1列有那些資料庫的欄位 就顯示那些資料
   
10.     '如空白 會顯示全部欄位的資料
    
11.     Sheet2.Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).CurrentRegion
    
12. End Sub

複製代碼

smouse0220

回復  smouse0220


真的太謝謝你了，這樣讓又能繼續寫下去了!

第15列中的                         ...
假面超人 發表於 2012-8-2 13:31

0802.rar (9.52 KB)

下載次數: 5

2012-8-2 19:32

假面超人

回復 11# GBKEE

追加問一個問題
如果要搜尋123,124兩筆資料
123的資料在工作頁2裡可找到
124的資料在工作頁3裡可找到

我用您的程式碼修改

1. For a = 2 To 3
   
2.             Sheets(a).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).CurrentRegion
   
3.         Next

複製代碼

加了這迴圈，這樣他兩筆資料都會找到，可是當第2次找到時就會把第1次找到的資料蓋掉，是否可以讓第二2找到的資料在第1次的資料之下以此類推

假面超人

回復 12# smouse0220

sorry...
我的等級不足，無法下載檔案，是否方便上傳到免空
http://imxd.net/

smouse0220

回復 14# 假面超人

Fyi.
http://imxd.net/file?id=6716

GBKEE

回復 13# 假面超人

1. Option Explicit
   
2. Sub Ex() '有多於2個以上的工作表要篩選
   
3.     Dim Rng(1 To 3) As Range, a As Integer, Sh_Count As Integer
   
4.     Sh_Count = Sheets.Count   '此活頁簿中工作表的總數
   
5.     Set Rng(1) = Sheets(1).Range("a1").CurrentRegion   '進階篩選: 準則範圍  取得為 Sheet1[A1:A3]
   
6.     'Set Rng(2) = Sheets("最終結果").Range("A1").CurrentRegion  '改為此活頁簿中最後的工作表
   
7.     Set Rng(2) = Sheets(Sh_Count).Range("A1").CurrentRegion
   
8.     Rng(2) = ""                                     '清理先前篩選的資料
   
9.     Rng(1).Rows(1).Copy Rng(2).Cells(1)             '複製 準則的欄位
   
10.     For a = 2 To Sheets.Count - 1
    
11.         Sheets(a).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
    
12.         Set Rng(2) = Rng(2).Cells(1).End(xlDown).Offset(1) '複製到目的範圍 往下移動
    
13.         If a <> Sheets.Count - 1 Then Rng(1).Rows(1).Copy Rng(2).Cells(1)
    
14.         If Rng(3) Is Nothing Then             '紀錄複製第2個工作表以後的複製到目的範圍欄位 第一列位置
    
15.             Set Rng(3) = Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
    
16.         Else
    
17.             Set Rng(3) = Union(Rng(3), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count))
    
18.         End If
    
19.     Next
    
20.     If Not Rng(3) Is Nothing Then Rng(3).Delete xlUp  '刪除 紀錄複製第2個工作表以後的複製到目的範圍欄位 第一列位置
    
21. End Sub

複製代碼

假面超人

回復 16# GBKEE


GBKEE版大一直麻煩你真的不好意思
針對您寫的那程式做了測試大致上沒問題
但有點小問題
搜尋到最後的排序會依照先在哪個分頁找到的寫入到最後會亂掉，是否可以能讓資料順序和工作頁1一樣?謝謝
多筆資料判斷(G大).rar (16.05 KB)

下載次數: 6

2012-8-2 21:26

c_c_lai

回復 16# GBKEE
請教：
        Sheets(a).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
是不是要修改成：
        Sheets(2).Range("A1").CurrentRegion.AdvancedFilter xlFilterCopy, Rng(1), Rng(2).Cells(1).Resize(1, Rng(1).Columns.Count)
否則下一個工作表單如為空白，則會有錯誤訊息。

c_c_lai

回復 16# GBKEE
看了#17樓的範例，霍然大悟。因為範例中沒有空白表單之故。

Hsieh

回復 17# 假面超人
是要照Sheet1的排序嗎?

1. Sub nn()
   
2. Dim Ar(), A As Range, B As Range
   
3. With Sheets("Sheet1")
   
4. For Each A In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))  第一頁A2以下做迴圈
   
5.   For Each Sh In Sheets(Array("Sheet2", "Sheet3")) '原資料所在工作表
   
6.   With Sh
   
7.      For Each B In .Range(.[A2], .Cells(.Rows.Count, 1).End(xlUp))  '在A2以下儲存格做迴圈
   
8.         If B = A Then  '跟第一頁A欄儲存格做比對，如果符合
   
9.            ReDim Preserve Ar(s)  '擴大陣列
   
10.            Ar(s) = Array(B.Value, B.Offset(, 1).Value, B.Offset(, 2).Value, B.Offset(, 4).Value)  '將值寫入陣列
    
11.            s = s + 1  '準備下一次擴大陣列
    
12.         End If
    
13.      Next
    
14.   End With
    
15.   Next
    
16.   With Sheets("最終結果")
    
17.      If s > 0 Then .Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(s, 4).Value = Application.Transpose(Application.Transpose(Ar))  '如果陣列有寫入，就將陣列寫入結果
    
18.      Erase Ar: s = 0  '清空陣列，並準備下一個陣列初始大小
    
19.   End With
    
20. Next
    
21. End With
    
22. End Sub

複製代碼