GBKEE

¦^´_  sunnyso
    »¡¿ù...
¬O°µ±Æ§Ç¿z¿ï..¦]µ§¼Æ¦³¤W¤dµ§...­n±qªí³æ¤¤§ì¥X­«ÂÐ
sillykin µoªí©ó 2013/8/31 13:34

[±Æ§Ç¿z¿ï..  §ì¥X­«ÂÐ ]  ½Ð©w¸q: ­þ¸Ìªº­«ÂÐ

GBKEE

¦^´_ 6# 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" ¤u§@ªí¦WºÙ
   
5.         .Cells.Interior.ColorIndex = xlNone
   
6.         Set Rng(1) = .Range("A:F").SpecialCells(xlCellTypeConstants)                              '¸ê®Æ®w
   
7.         .Range("G:G") = ""
   
8.         Set Rng(3) = Rng(1).Rows(1)
   
9.         For i = 3 To 5                                      'CÄæ¡BDÄæ¡BEÄæ¦ì°µ¬°·Ç«h
   
10.             .Cells(1, .Columns.Count) = Rng(1).Cells(1, i)  'Äæ¦ì°µ¬°·Ç«h
    
11.             Rng(1).Columns(i).AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True       '¿z¿ï¤£­«½Æªº¸ê®Æ
    
12.             Set Rng(2) = .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown))  '¿z¿ï¥Xªº¸ê®Æ½d³ò
    
13.             For Each E In Rng(2)
    
14.                 If Application.CountIf(Rng(1).Columns(i), E) > 1 Then                              ' ¸ê®Æ¦b¸ê®Æ®w¸Ìªº¸ê®Æ¼Æ¤j©ó1
    
15.                     With Rng(1).Columns(i).Cells
    
16.                         .Replace E, "=XXX", xlWhole                                                '§ó§ï¬°¿ù»~­È
    
17.                         With .SpecialCells(xlCellTypeFormulas, xlErrors)                           '¿ù»~­Èªº¯S®í½d³ò¸Ì
    
18.                             .Value = E                                                             '¸m¦^­ì¨Óªº¸ê®Æ
    
19.                             Set Rng(3) = Union(Rng(3), .Cells)                                     '¥[¤J½d³ò
    
20.                             .Interior.Color = vbYellow
    
21.                             .Offset(, Rng(1).Columns.Count + 1 - i) = "­«ÂнЬd®Ö"
    
22.                         End With
    
23.                     End With
    
24.                 End If
    
25.             Next
    
26.         Next
    
27.         .Cells(1, .Columns.Count).EntireColumn = ""
    
28.         Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow)  '¾ã¦X¬°¾ã¦C
    
29.     End With
    
30.     With Sheets("Sheet2")
    
31.         .Cells.Clear
    
32.         Rng(3).Copy .Range("A1")
    
33.         .Cells.Interior.ColorIndex = xlNone
    
34.         .Cells.EntireColumn.AutoFit
    
35.     End With
    
36. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 8# c_c_lai
.Replace E, "=XXX", xlWhole  ªº§@¥Î¦ó¦b¡H  ±N¸ê®Æ®w­n·j´Mªº¦r¦ê¤@¦¸Åܬ°µL®Äªº¤½¦¡(¿ù»~­È)
With .SpecialCells(xlCellTypeFormulas, xlErrors) ->½d³ò¤¤ªº¯S®íÀx¦s(¿ù»~­È)

GBKEE

¦^´_ 11# sillykin
Rng(3)¦bµ{¦¡¤¤°õ¦æ¤@ª½¬O¤£³sÄòªº°Ï¶ô(Äæ¼Æ¦ì¸m¤£¤@¼Ë),µLªk¥ÎCopy ªº¤èªk
Set Rng(3) = Application.Intersect(.Cells, Rng(3).EntireRow)  '¾ã¦X¬°¾ã¦C(Äæ¼Æ¦ì¸m¤@¼Ë)¥i¤@°_Copy ½Æ»s¨ì¨ä¥L¦a¤è

1. EntireRow ÄÝ©Ê
   
2. ½Ð°Ñ¾\®M¥Î¦Ü½d¨Ò¯S©w¶Ç¦^ Range ª«¥ó¡A¸Óª«¥ó¥Nªí¥]§t«ü©w½d³òªº¾ã­Ó¦C (©Î­Y¤z¦C)¡C°ßŪ

½Æ»s¥N½X

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¤»­Ó¿ï¶µ¶·­«·s,¨Ì§Ç©R¦W ComboBox1(²Õ§O) ...-> ComboBox6(¤¸)
    
13.     Next
    
14. End Sub
    
15. Private Sub CommandButton1_Click() '¿z¿ï±ø¥ó
    
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   'Åã¥Ü¥þ³¡¸ê®Æ ->·sªº ¦h­«¿z¿ï ¤~·|½T.
    
20.     '¦h­«¿z¿ï  ..........
    
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") '½d³ò
    
32.         .Parent.AutoFilterMode = False   'Åã¥Ü¥þ³¡¸ê®Æ ->¨ú®ø ¦h­«¿z¿ï
    
33.     End With
    
34. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 18# sillykin

1. Option Explicit
   
2. Option Base 1  '<- ¤U­­­È¬° 1  ; ­Y­n³]¤U­­­È¬° 0¡A«h Option Base ³¯­z¦¡¬O¤£»Ý­nªº¡C
   
3. 
   
4. Dim Ar(), Ax()                            '³o¼Ò²Õ¤¤ªºµ{¦¡¥i¥Î¤§ÅܼÆ
   
5. Private Sub UserForm_Initialize()
   
6.     Dim D(1 To 6) As Object, i As Integer, R As Variant
   
7.     '********¦pªGSHEET1Äæ¦ì­È¬°A~DÄæ¦ì¤ÎFÄæ¦ì¤ÎGÄæ¦ì..***
   
8.     Ar = Array(1, 2, 3, 4, 6, 7)   '³]©wÄæ¦ì
   
9.     '****************************************************
   
10.     Ax = Array(ComboBox1, ComboBox2, ComboBox3, ComboBox4, ComboBox5, ComboBox6)    'ComboBox¤»­Ó¿ï¶µ¤º®e¨Ì§Ç¬° ²Õ§O,©m¦W1....
    
11.     With Sheet1
    
12.         .AutoFilterMode = False   'Åã¥Ü¥þ³¡¸ê®Æ ->·sªº ¦h­«¿z¿ï ¤~·|½T.
    
13.         For i = 1 To 6
    
14.             Set D(i) = CreateObject("Scripting.Dictionary")
    
15.             For Each R In .Range("A2", .[A2].End(xlDown))
    
16.                  '************ ­Y¹w³]ªº¤U­­­È¬° 0  ->   i - 1   *******************************************************
    
17.                  'D(i)(R.Offset(, Ar(i - 1) - 1).Value) = ""    'i = 1 ®É ­Y¹w³]ªº¤U­­­È¬°0 «h»Ý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() '¿z¿ï±ø¥ó
    
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       'Åã¥Ü¥þ³¡¸ê®Æ ->·sªº ¦h­«¿z¿ï ¤~·|½T.
    
30.     For i = 1 To 6                          '¦h­«¿z¿ï  ..........
    
31.         '************ ­Y¹w³]ªº¤U­­­È¬° 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øó)¬°¼Æ­È¤£¥i¥Î * ¨Ó¿z¿ï
    
36.     Next
    
37.     Application.ScreenUpdating = True
    
38. End Sub
    
39. Private Sub CommandButton4_Click()
    
40.     With ActiveSheet.Range("$A$1:$Q$300") '½d³ò
    
41.         .Parent.AutoFilterMode = False   'Åã¥Ü¥þ³¡¸ê®Æ ->¨ú®ø ¦h­«¿z¿ï
    
42.     End With
    
43. End Sub

½Æ»s¥N½X

GBKEE

¦^´_ 20# sillykin
¥i¨Ì¼Ëµe¸¬Äª¸Õ¸Õ¬Ý,¦³°ÝÃD¥i¦A´£°Ý(¦h½m²ßVBA·|¶i¨Bªº)

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" ¤u§@ªí¦WºÙ
   
5.    
   
6.     With Sheet1                     ' Sheet1  ¤u§@ªíª«¥ó¦WºÙ
   
7.         .Cells.Interior.ColorIndex = xlNone
   
8.         Set Rng(1) = .Range("A:F").SpecialCells(xlCellTypeConstants)                                    '¸ê®Æ®w
   
9.         .Range("G:G") = ""
   
10.         Set Rng(3) = Rng(1).Rows(1)
    
11.         For i = 1 To 7                                                                                  'CÄæ¡BDÄæ¡BEÄæ¦ì°µ¬°·Ç«h
    
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)                                          'Äæ¦ì°µ¬°·Ç«h
    
15.                 Rng(1).Columns(i).AdvancedFilter xlFilterCopy, , .Cells(1, .Columns.Count), True        '¿z¿ï¤£­«½Æªº¸ê®Æ
    
16.                 Set Rng(2) = .Range(.Cells(2, .Columns.Count), .Cells(2, .Columns.Count).End(xlDown))   '¿z¿ï¥Xªº¸ê®Æ½d³ò
    
17.                 For Each E In Rng(2)
    
18.                     If Application.CountIf(Rng(1).Columns(i), E) > 1 Then                               ' ¸ê®Æ¦b¸ê®Æ®w¸Ìªº¸ê®Æ¼Æ¤j©ó1
    
19.                         With Rng(1).Columns(i).Cells
    
20.                             .Replace E, "=XXX", xlWhole                                                 '§ó§ï¬°¿ù»~­È
    
21.                             With .SpecialCells(xlCellTypeFormulas, xlErrors)                            '¿ù»~­Èªº¯S®í½d³ò¸Ì
    
22.                                 .Value = E                                                              '¸m¦^­ì¨Óªº¸ê®Æ
    
23.                                 Set Rng(3) = Union(Rng(3), .Cells)                                      '¥[¤J½d³ò
    
24.                                 .Interior.Color = vbYellow
    
25.                                 .Offset(, Rng(1).Columns.Count + 1 - i) = "­«ÂнЬd®Ö"
    
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)  '¾ã¦X¬°¾ã¦C
    
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

½Æ»s¥N½X

¤U¸ü (27.07 KB)

2013-9-8 06:40

¤U¸ü (42.49 KB)

2013-9-8 06:40