帖子: 18
主題: 6
精華: 0
積分: 29
點名: 0
作業系統: WINXP
軟體版本: OFFICE2000
閱讀權限: 10
性別: 男
來自: HK
註冊時間: 2011-11-22
最後登錄: 2012-5-18

1^# 跳轉到 » 倒序看帖

字體大小: tT

發表於 2011-12-27 00:12 | 只看該作者

[發問] 篩選資料問題?

本帖最後由 idsmchow 於 2011-12-27 00:14 編輯

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

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)' 這一句上?

請問如何修正?

謝謝

Statement.rar (129.36 KB)

樓主熱帖

register313

　頭銜: 麻辣路人甲

大學生 Rank: 4

帖子: 967
主題: 0
精華: 0
積分: 1001
點名: 0
作業系統: WIN XP
軟體版本: OFFICE 2003
閱讀權限: 50
性別: 男
來自: 台北
註冊時間: 2010-11-29
最後登錄: 2022-5-17

2012龍年全勤獎章熱烈參與勳章

2^#

發表於 2011-12-27 13:53 | 只看該作者

回復 1# idsmchow

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

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

3^#

發表於 2011-12-27 15:50 | 只看該作者

回復 1# idsmchow

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

複製代碼

TOP

idsmchow

小學生 Rank: 1

帖子: 18
主題: 6
精華: 0
積分: 29
點名: 0
作業系統: WINXP
軟體版本: OFFICE2000
閱讀權限: 10
性別: 男
來自: HK
註冊時間: 2011-11-22
最後登錄: 2012-5-18

4^#

發表於 2011-12-27 23:48 | 只看該作者

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

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

TOP

register313

　頭銜: 麻辣路人甲

大學生 Rank: 4

帖子: 967
主題: 0
精華: 0
積分: 1001
點名: 0
作業系統: WIN XP
軟體版本: OFFICE 2003
閱讀權限: 50
性別: 男
來自: 台北
註冊時間: 2010-11-29
最後登錄: 2022-5-17

2012龍年全勤獎章熱烈參與勳章

5^#

發表於 2011-12-28 00:32 | 只看該作者

本帖最後由 register313 於 2011-12-28 00:36 編輯

回復 4# idsmchow

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

Statement.rar (151.54 KB)

TOP

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2011-12-28 15:23 | 只看該作者

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

TOP

register313

　頭銜: 麻辣路人甲

大學生 Rank: 4

帖子: 967
主題: 0
精華: 0
積分: 1001
點名: 0
作業系統: WIN XP
軟體版本: OFFICE 2003
閱讀權限: 50
性別: 男
來自: 台北
註冊時間: 2010-11-29
最後登錄: 2022-5-17

2012龍年全勤獎章熱烈參與勳章

7^#

發表於 2011-12-28 15:32 | 只看該作者

回復 6# GBKEE

感謝GBKEE版大一直給予指導

TOP

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 244
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-10

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

8^#

發表於 2011-12-28 17:40 | 只看該作者

回復 1# idsmchow

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