麻辣家族討論版版 - Powered by Discuz! Board

標題: VBA做篩選 [打印本頁]

作者: sillykin 時間: 2013-8-30 18:48 標題: VBA做篩選

因資料有上千筆…
可否能用VBA做篩選..有參考本網站之篩選範例..還是做不太出來..
問題一、
篩選C欄、D欄、E欄位做為準則
排列順序，且在Ｇ欄能否標示一下『重覆請查核』
問題二、
可否加註顏色做為比對依據
問題三、
SHEET1為資料區
篩選出來可否在COPY到SHEET2

請大大協助一下…感恩

作者: sunnyso 時間: 2013-8-31 11:49

篩選C欄、D欄、E欄位做為準則
C欄、D欄、E欄位是AND嗎

作者: sillykin 時間: 2013-8-31 13:34

回復 2# sunnyso

說錯...
是做排序篩選..因筆數有上千筆...要從表單中抓出重覆

作者: GBKEE 時間: 2013-9-1 12:49

回復 sunnyso
說錯...
是做排序篩選..因筆數有上千筆...要從表單中抓出重覆
sillykin 發表於 2013/8/31 13:34

[排序篩選.. 抓出重覆 ] 請定義: 哪裡的重覆

作者: sillykin 時間: 2013-9-1 13:24

謝謝G大出手協助..
B欄姓名1(不用管此欄位值)
比對C欄、E欄
C欄姓名2(重覆)
E欄序號(重覆)

作者: GBKEE 時間: 2013-9-1 15:05

回復 6# sillykin
試試看

Option Explicit
Sub Ex()
Dim Rng(1 To 3) As Range, i As Integer, E As Range
With Sheets("Sheet1") ' "Sheet1" 工作表名稱
.Cells.Interior.ColorIndex = xlNone
Set Rng(1) = .Range("A:F").SpecialCells(xlCellTypeConstants) '資料庫
.Range("G:G") = ""
Set Rng(3) = Rng(1).Rows(1)
For i = 3 To 5 'C欄、D欄、E欄位做為準則
.Cells(1, .Columns.Count) = Rng(1).Cells(1, i) '欄位做為準則
Rng(1).Columns(i).AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True '篩選不重複的資料
Set Rng(2) = .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown)) '篩選出的資料範圍
For Each E In Rng(2)
If Application.CountIf(Rng(1).Columns(i), E) > 1 Then ' 資料在資料庫裡的資料數大於1
With Rng(1).Columns(i).Cells
.Replace E, "=XXX", xlWhole '更改為錯誤值
With .SpecialCells(xlCellTypeFormulas, xlErrors) '錯誤值的特殊範圍裡
.Value = E '置回原來的資料
Set Rng(3) = Union(Rng(3), .Cells) '加入範圍
.Interior.Color = vbYellow
.Offset(, Rng(1).Columns.Count + 1 - i) = "重覆請查核"
End With
End With
End If
Next
Next
.Cells(1, .Columns.Count).EntireColumn = ""
Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow) '整合為整列
End With
With Sheets("Sheet2")
.Cells.Clear
Rng(3).Copy .Range("A1")
.Cells.Interior.ColorIndex = xlNone
.Cells.EntireColumn.AutoFit
End With
End Sub

複製代碼

作者: c_c_lai 時間: 2013-9-1 15:41

回復 7# GBKEE
請教您：
此處您安排 .Replace E, "=XXX", xlWhole 的作用何在？
它又與 With .SpecialCells(xlCellTypeFormulas, xlErrors) 之間
有何關聯？
謝謝您！

作者: GBKEE 時間: 2013-9-1 15:53

回復 8# c_c_lai
.Replace E, "=XXX", xlWhole 的作用何在？將資料庫要搜尋的字串一次變為無效的公式(錯誤值)
With .SpecialCells(xlCellTypeFormulas, xlErrors) ->範圍中的特殊儲存(錯誤值)

作者: sillykin 時間: 2013-9-1 16:04

回復 10# GBKEE

.Cells(1, .Columns.Count).EntireColumn = ""
Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow) '整合為整列

請問g大版主..上面這二條的意思是什麼..有點看不太懂...

作者: GBKEE 時間: 2013-9-1 16:33

回復 11# sillykin
Rng(3)在程式中執行一直是不連續的區塊(欄數位置不一樣),無法用Copy 的方法
Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow) '整合為整列(欄數位置一樣)可一起Copy 複製到其他地方

EntireRow 屬性
請參閱套用至範例特定傳回 Range 物件，該物件代表包含指定範圍的整個列 (或若干列)。唯讀

複製代碼

作者: c_c_lai 時間: 2013-9-1 18:00

回復 c_c_lai
.Replace E, "=XXX", xlWhole 的作用何在？將資料庫要搜尋的字串一次變為無效的公式(錯 ...
GBKEE 發表於 2013-9-1 15:53

謝謝您的詮釋，字面上意義我都了解，
原本我要的是為何如此處哩，以及用意。
經實際 Debug 終於瞭解實際的巧妙應用，
謝謝你！

作者: sillykin 時間: 2013-9-2 22:45

G大版主你好..不好意思..另有一個小問題想請教..如圖所示 :

作者: GBKEE 時間: 2013-9-3 09:16

回復 15# sillykin

Option Explicit
Private Sub UserForm_Initialize()
Dim D(1 To 6) As Object, i As Integer, R As Variant
For i = 1 To 6
Set D(i) = CreateObject("Scripting.Dictionary")
With Sheet1
For Each R In .Range("A2", .[A2].End(xlDown)) '
D(i)(R.Offset(, i - 1).Value) = ""
Next
End With
Controls("ComboBox" & i).List = Application.Transpose(D(i).keys)
'ComboBox六個選項須重新,依序命名 ComboBox1(組別) ...-> ComboBox6(元)
Next
End Sub
Private Sub CommandButton1_Click() '篩選條件
Dim Rng As Range, i As Integer
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("$A$1:$Q$300")
Rng.Parent.AutoFilterMode = False '顯示全部資料 ->新的多重篩選才會確.
'多重篩選 ..........
For i = 1 To 6
With Controls("ComboBox" & i)
If .Value <> "" Then
Rng.AutoFilter Field:=i, Criteria1:=.Value & "*" '
End If
End With
Next
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton4_Click()
With ActiveSheet.Range("$A$1:$Q$300") '範圍
.Parent.AutoFilterMode = False '顯示全部資料 ->取消多重篩選
End With
End Sub

複製代碼

作者: sillykin 時間: 2013-9-3 23:15

G大版主你好..不好意思在吵你一下..
For i = 1 To 6

22.       With Controls("ComboBox" & i)

23.          If .Value <> "" Then

24.             Rng.AutoFilter Field:=i, Criteria1:=.Value & "*" '

25.          End If

26.       End With
是控制ComboBox" & i (1~6的控制選項)
如果SHEET1欄位值為A~D欄位及F欄位及G欄位..要如何下VBA程式呢??
因FOR 1 TO 6 為連續ComboBox選A~F欄位
請G大版主點一下..小弟不才..謝謝

作者: GBKEE 時間: 2013-9-4 10:24

本帖最後由 GBKEE 於 2013-9-4 10:36 編輯

回復 18# sillykin

Option Explicit
Option Base 1 '<- 下限值為 1 ; 若要設下限值為 0，則 Option Base 陳述式是不需要的。
Dim Ar(), Ax() '這模組中的程式可用之變數
Private Sub UserForm_Initialize()
Dim D(1 To 6) As Object, i As Integer, R As Variant
'********如果SHEET1欄位值為A~D欄位及F欄位及G欄位..***
Ar = Array(1, 2, 3, 4, 6, 7) '設定欄位
'****************************************************
Ax = Array(ComboBox1, ComboBox2, ComboBox3, ComboBox4, ComboBox5, ComboBox6) 'ComboBox六個選項內容依序為組別,姓名1....
With Sheet1
.AutoFilterMode = False '顯示全部資料 ->新的多重篩選才會確.
For i = 1 To 6
Set D(i) = CreateObject("Scripting.Dictionary")
For Each R In .Range("A2", .[A2].End(xlDown))
'************ 若預設的下限值為 0 -> i - 1 *******************************************************
'D(i)(R.Offset(, Ar(i - 1) - 1).Value) = "" 'i = 1 時若預設的下限值為0 則需Ar(i - 1)-> Ar(0) = 1'*
'*****************************************************************************************************
D(i)(R.Offset(, Ar(i) - 1).Value) = ""
Next
Ax(i).List = Application.Transpose(D(i).keys)
Next
End With
End Sub
Private Sub CommandButton1_Click() '篩選條件
Dim Rng As Range, i As Integer
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("$A$1:$Q$300")
Rng.Parent.AutoFilterMode = False '顯示全部資料 ->新的多重篩選才會確.
For i = 1 To 6 '多重篩選 ..........
'************ 若預設的下限值為 0 -> i - 1 *****************************************************
'If Ax(i - 1).Value <> "" Then Rng.AutoFilter Field:=Ar(i - 1), Criteria1:=Ax(i - 1).Value & "*" '*
'***************************************************************************************************
If Ax(i).Value <> "" Then Rng.AutoFilter Field:=Ar(i), Criteria1:=IIf(i <> 5, Ax(i).Value & "*", Ax(i).Value)
'元(F欗)為數值不可用 * 來篩選
Next
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton4_Click()
With ActiveSheet.Range("$A$1:$Q$300") '範圍
.Parent.AutoFilterMode = False '顯示全部資料 ->取消多重篩選
End With
End Sub

複製代碼

作者: sillykin 時間: 2013-9-4 21:21

回復 sillykin
試試看
GBKEE 發表於 1/9/2013 15:05

g大版主你好..小弟不才..也謝謝版主耐心的教導
承前題回覆6的公式

01.Option Explicit

02.Sub Ex()

03. Dim Rng(1 To 3) As Range, i As Integer, E As Range

04. With Sheets("Sheet1")       ' "Sheet1" 工作表名稱

05.       .Cells.Interior.ColorIndex = xlNone

06.       Set Rng(1) = .Range("A:F").SpecialCells(xlCellTypeConstants)                            '資料庫

07.       .Range("G:G") = ""

08.       Set Rng(3) = Rng(1).Rows(1)

09.       For i = 3 To 5                                     'C欄、D欄、E欄位做為準則

10.          .Cells(1, .Columns.Count) = Rng(1).Cells(1, i)  '欄位做為準則

11.          Rng(1).Columns(i).AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True    '篩選不重複的資料

12.          Set Rng(2) = .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown))  '篩選出的資料範圍

  For i = 3 To 5                                     'C欄、D欄、E欄位做為準則
如果更改為C欄、E欄位做為準則 ;D欄不做準則
那做法是不是跟你上一題的方式一樣呢????

作者: GBKEE 時間: 2013-9-5 08:26

回復 20# sillykin
可依樣畫葫蘆試試看,有問題可再提問(多練習VBA會進步的)

作者: sillykin 時間: 2013-9-8 00:57

回復 21# GBKEE

G大版主..又一個小問題請教...
如果改為CheckBox勾選做為準則呢..這要如何去處理呢????

作者: GBKEE 時間: 2013-9-8 06:41

回復 18# sillykin

Option Explicit
Sub Ex()
Dim Rng(1 To 3) As Range, i As Integer, E As Range
'With Sheets("Sheet1") ' "Sheet1" 工作表名稱
With Sheet1 ' Sheet1 工作表物件名稱
.Cells.Interior.ColorIndex = xlNone
Set Rng(1) = .Range("A:F").SpecialCells(xlCellTypeConstants) '資料庫
.Range("G:G") = ""
Set Rng(3) = Rng(1).Rows(1)
For i = 1 To 7 'C欄、D欄、E欄位做為準則
MsgBox .OLEObjects("CheckBox" & i).Object
If .OLEObjects("CheckBox" & i).Object.Value = True Then '有勾選=.Value = True *****
.Cells(1, .Columns.Count) = Rng(1).Cells(1, i) '欄位做為準則
Rng(1).Columns(i).AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True '篩選不重複的資料
Set Rng(2) = .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown)) '篩選出的資料範圍
For Each E In Rng(2)
If Application.CountIf(Rng(1).Columns(i), E) > 1 Then ' 資料在資料庫裡的資料數大於1
With Rng(1).Columns(i).Cells
.Replace E, "=XXX", xlWhole '更改為錯誤值
With .SpecialCells(xlCellTypeFormulas, xlErrors) '錯誤值的特殊範圍裡
.Value = E '置回原來的資料
Set Rng(3) = Union(Rng(3), .Cells) '加入範圍
.Interior.Color = vbYellow
.Offset(, Rng(1).Columns.Count + 1 - i) = "重覆請查核"
End With
End With
End If
Next
End If
Next
.Cells(1, .Columns.Count).EntireColumn = ""
Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow) '整合為整列
End With
With Sheets("Sheet2")
.Cells.Clear
Rng(3).Copy .Range("A1")
.Cells.Interior.ColorIndex = xlNone
.Cells.EntireColumn.AutoFit
End With
End Sub

複製代碼

[attach]15978[/attach]

[attach]15979[/attach]

作者: sillykin 時間: 2013-9-10 22:12

謝謝g大版主的教導...小弟由衷感謝

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)