c_c_lai

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

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

sillykin

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

GBKEE

回復 15# sillykin

1. Option Explicit
   
2. Private Sub UserForm_Initialize()
   
3.     Dim D(1 To 6) As Object, i As Integer, R As Variant
   
4.     For i = 1 To 6
   
5.         Set D(i) = CreateObject("Scripting.Dictionary")
   
6.         With Sheet1
   
7.             For Each R In .Range("A2", .[A2].End(xlDown)) '
   
8.                  D(i)(R.Offset(, i - 1).Value) = ""
   
9.             Next
   
10.         End With
    
11.         Controls("ComboBox" & i).List = Application.Transpose(D(i).keys)
    
12.         'ComboBox六個選項須重新,依序命名 ComboBox1(組別) ...-> ComboBox6(元)
    
13.     Next
    
14. End Sub
    
15. Private Sub CommandButton1_Click() '篩選條件
    
16.     Dim Rng As Range, i As Integer
    
17.     Application.ScreenUpdating = False
    
18.     Set Rng = ActiveSheet.Range("$A$1:$Q$300")
    
19.     Rng.Parent.AutoFilterMode = False   '顯示全部資料 ->新的 多重篩選 才會確.
    
20.     '多重篩選  ..........
    
21.     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
    
27.     Next
    
28.     Application.ScreenUpdating = True
    
29. End Sub
    
30. Private Sub CommandButton4_Click()
    
31.     With ActiveSheet.Range("$A$1:$Q$300") '範圍
    
32.         .Parent.AutoFilterMode = False   '顯示全部資料 ->取消 多重篩選
    
33.     End With
    
34. End Sub

複製代碼

sillykin

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

回復 18# sillykin

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

複製代碼

sillykin

回復  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

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

sillykin

回復 21# GBKEE


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

GBKEE

回復 18# sillykin

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim Rng(1 To 3) As Range, i As Integer, E As Range
   
4.     'With Sheets("Sheet1")          ' "Sheet1" 工作表名稱
   
5.    
   
6.     With Sheet1                     ' Sheet1  工作表物件名稱
   
7.         .Cells.Interior.ColorIndex = xlNone
   
8.         Set Rng(1) = .Range("A:F").SpecialCells(xlCellTypeConstants)                                    '資料庫
   
9.         .Range("G:G") = ""
   
10.         Set Rng(3) = Rng(1).Rows(1)
    
11.         For i = 1 To 7                                                                                  'C欄、D欄、E欄位做為準則
    
12.            MsgBox .OLEObjects("CheckBox" & i).Object
    
13.             If .OLEObjects("CheckBox" & i).Object.Value = True Then     '有勾選=.Value = True       *****
    
14.                 .Cells(1, .Columns.Count) = Rng(1).Cells(1, i)                                          '欄位做為準則
    
15.                 Rng(1).Columns(i).AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True        '篩選不重複的資料
    
16.                 Set Rng(2) = .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown))   '篩選出的資料範圍
    
17.                 For Each E In Rng(2)
    
18.                     If Application.CountIf(Rng(1).Columns(i), E) > 1 Then                               ' 資料在資料庫裡的資料數大於1
    
19.                         With Rng(1).Columns(i).Cells
    
20.                             .Replace E, "=XXX", xlWhole                                                 '更改為錯誤值
    
21.                             With .SpecialCells(xlCellTypeFormulas, xlErrors)                            '錯誤值的特殊範圍裡
    
22.                                 .Value = E                                                              '置回原來的資料
    
23.                                 Set Rng(3) = Union(Rng(3), .Cells)                                      '加入範圍
    
24.                                 .Interior.Color = vbYellow
    
25.                                 .Offset(, Rng(1).Columns.Count + 1 - i) = "重覆請查核"
    
26.                             End With
    
27.                         End With
    
28.                     End If
    
29.                 Next
    
30.             End If
    
31.         Next
    
32.         .Cells(1, .Columns.Count).EntireColumn = ""
    
33.         Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow)  '整合為整列
    
34.     End With
    
35.     With Sheets("Sheet2")
    
36.         .Cells.Clear
    
37.         Rng(3).Copy .Range("A1")
    
38.         .Cells.Interior.ColorIndex = xlNone
    
39.         .Cells.EntireColumn.AutoFit
    
40.     End With
    
41. End Sub

複製代碼

下載 (27.07 KB)

2013-9-8 06:40

下載 (42.49 KB)

2013-9-8 06:40

sillykin

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