[發問] 篩選資料問題?

idsmchow

請問如何修改以下的巨集??

Private Sub CommandButton1_Click()
Dim eachsht As Worksheet, eachrng As Range, tmpTbl As Range
For Each eachsht In Worksheets
If eachsht.Name <> "Statement" Then
Set eachrng = Sheets("Statement").Range("a65536").End(xlUp).Offset(1)
Set tmpTbl = eachsht.Range("a2").CurrentRegion
eachsht.Range("a2").CurrentRegion.AutoFilter Field:=3, Criteria1:=Sheets("Statement").Range("G2"), Operator:=xlAnd
tmpTbl.Rows("2:" & tmpTbl.Rows.Count).Copy eachrng
End If
Next
End Sub

當乎合條件的要求, 例如 "AA Ltd" 條件都在 Jan , Feb. Mar Sheet - 資料表出現的話, 這巨集就能正確篩選所需的資料及複製到Statement Sheet.

但條件不乎合資料表的話 例如 "EE Ltd" 這巨集就會將所有沒有關係的資料一併轉寫.

問題是否出於 ' tmpTbl.Rows("2:" & tmpTbl.Rows.Count)' 這一句上?

請問如何修正?

謝謝

register313

回復 1# idsmchow


     tmpTbl.Rows("2:" & tmpTbl.Rows.Count +1)   
     多複製一列空白列

GBKEE

回復 1# idsmchow

1. Private Sub CommandButton1_Click()
   
2.     Dim eachsht As Worksheet, eachrng As Range
   
3.     For Each eachsht In Worksheets
   
4.         With eachsht
   
5.             If .Name <> "Statement" Then
   
6.                 .Range("a1").AutoFilter Field:=3, Criteria1:=Sheets("Statement").Range("G2"), Operator:=xlAnd
   
7.                 If .Range("a" & Rows.Count).End(xlUp).Row > 1 Then '有篩選到所需的資料
   
8.                     Set eachrng = Sheets("Statement").Range("a" & Rows.Count).End(xlUp).Offset(1)
   
9.                     .Rows("2:" & .Range("a" & Rows.Count).End(xlUp).Row).Copy eachrng
   
10.                 End If
    
11.                 .Range("a2").CurrentRegion.AutoFilter              '沒有指定準則->顯示全部資料
    
12.             End If
    
13.         End With
    
14.     Next
    
15. End Sub

複製代碼

idsmchow

問題已解決, 謝謝各位的回覆

但register313 的答案
tmpTbl.Rows("2:" & tmpTbl.Rows.Count +1)
好像不正確

register313

回復 4# idsmchow


程式是依樓主之意作最少之修正
也許不完美
但如何不正確 請說明清楚 讓我知道問題
與GBKEE版大程式執行之結果是相同的
Statement.rar (151.54 KB)

下載次數: 7

2011-12-28 00:32

GBKEE

回復 5# register313
沒錯.是一樣的效果,差別是你多複製空白的一列.
如果資料庫的資料是連續到工作表的最後一列,你我的程式都會出錯的

register313

回復 6# GBKEE
   
感謝GBKEE版大一直給予指導

Hsieh

回復 1# idsmchow

1. Private Sub CommandButton1_Click()
   
2. Dim Sh As Worksheet, Rng As Range
   
3. For Each Sh In Sheets
   
4. If Sh.Name <> "Statement" Then   '略過Statement工作表
   
5. With Sh
   
6.   If .AutoFilter.Filters(3).On Then .ShowAllData   '如果C欄沒有被篩選
   
7.      .Range("A1").CurrentRegion.AutoFilter 3, Sheets("Statement").Range("G2"), xlAnd   '就以C欄篩選
   
8.      Set Rng = Intersect(.[A2:D65536], .AutoFilter.Range.SpecialCells(xlCellTypeVisible))    'A:D蘭蒂2列以下與篩選結果的可見儲存格交集部分
   
9.      If Not Rng Is Nothing Then Rng.Copy Sheets("Statement").Range("A65536").End(xlUp).Offset(1, 0)  '複製
   
10. End With
    
11. End If
    
12. Next
    
13. End Su

複製代碼

idsmchow

回復 5# register313


    Hi register313,

你的解答是正確, 只是自己改動了一些格式, 而導致出現問題.
本人是初學者, 剛剛買了幾本書自學, 日後請多多指教.

對於日前的說法, 請多多包涵

再次謝謝

idsmchow

回復 8# Hsieh


    超級版主　所寫的巨集有部份語法, 在我購買的書本中沒有提及過。例如On Then.　Intersect.　比較高深

對於我（初學者）來說，　需要時間理解。

謝謝大家回覆。