hcm19522

http://blog.xuite.net/hcm19522/twblog/356624511
G21:L21»P®æ¦¡¤Æ ¥H "­ã¤j" ºë²

­ã´£³¡ªL

Sub °õ¦æ()
Dim xR As Range, MH, Brr
[B2:X18].Interior.ColorIndex = 0
[G21:L21].ClearContents
Brr = [G21:L21]
For Each xR In Range("B" & Replace([C20], "-", ":X"))
¡@¡@MH = Application.Match(xR, [G20:L20], 0)
¡@¡@If IsNumeric(MH) Then
¡@¡@¡@¡@xR.Interior.ColorIndex = [G19].Cells(1, MH).Interior.ColorIndex
¡@¡@¡@¡@Brr(1, MH) = Brr(1, MH) + 1
¡@¡@End If
Next
[G21:L21] = Brr
End Sub

s7659109

­ã¤j¡G
®M¥Îµ{¦¡½X«á¡Aµo²{³¡¤ÀÃC¦â¹ï·Ó¦³»~¡C
¥t¨C¦¸¦³­×§ï¡A»Ý¸õ¨ìµ{¦¡½X­¶­±­«·s°õ¦æ1¦¸¡A
­Y­n¦b¤u§@©³½Z¤¤¥[¤J§Ö³t¶s¡A¬O§_¥i¦æ¡H

yen956

¸Õ¸Õ¬Ý:

1. Sub ¶}©l²Î­p()
   
2.     Dim Cel As Range, Rng As Range
   
3.     Dim FstAddr As String, ndx As Integer, cNum As Integer
   
4.     Set Rng = Range("B" & [B21] & ":X" & [C21] & "")
   
5.     cNum = 0
   
6.     For Each Cel In [G20:L20]
   
7.         cNum = Cel.Offset(-1, 0).Interior.ColorIndex
   
8.         Cel.Interior.ColorIndex = cNum
   
9.         ndx = 0
   
10.         On Error GoTo next1
    
11.         Rng.Find(What:=Cel, LookIn:=xlFormulas, LookAt:=xlWhole).Activate
    
12.         FstAddr = ActiveCell.Address
    
13.         Cel.Interior.ColorIndex = cNum
    
14.         ActiveCell.Interior.ColorIndex = cNum
    
15.         Do
    
16.             ndx = ndx + 1
    
17.             On Error GoTo next1
    
18.             Rng.FindNext(After:=ActiveCell).Activate
    
19.             ActiveCell.Interior.ColorIndex = cNum
    
20.         Loop Until FstAddr = ActiveCell.Address
    
21. next1:
    
22.         Cel.Offset(1, 0) = ndx
    
23.     Next
    
24. End Sub
    
25. 
    
26. Private Sub Worksheet_Change(ByVal Target As Range)
    
27.     Dim Rng As Range
    
28.     Set Rng = Application.Union([B21:C21], [G20:L20])
    
29.     If Intersect(Target, Rng) Is Nothing Then Exit Sub
    
30.     If Not Intersect(Target, [B21:C21]) Is Nothing Then
    
31.         [B2:X18].Interior.ColorIndex = xlNone
    
32.         [G20:L20].Interior.ColorIndex = xlNone
    
33.         [G21:L21] = ""
    
34.         If [B21] > [C21] Then
    
35.             MsgBox "ª`·N:" & Chr(10) & "±Ò©l¦Cªº­È ¤£¥i¥H¤j©ó ²×¤î¦Cªº­È", vbCritical
    
36.             Exit Sub
    
37.         End If
    
38.     End If
    
39.     If Not Intersect(Target, [G20:L20]) Is Nothing Then
    
40.         [B2:X18].Interior.ColorIndex = xlNone
    
41.         [G20:L20].Interior.ColorIndex = xlNone
    
42.         [G21:L21] = ""
    
43.         [N21] = "= COUNTA(G20:L20)"
    
44.         If [N21] <> 6 Then Exit Sub
    
45.         [N20] = "=SUMPRODUCT((G20:L20<>"""")/COUNTIF(G20:L20,G20:L20&""""))"
    
46.         If [N20] < 6 Then
    
47.             MsgBox "ª`·N:" & Chr(10) & "¿é¤J°Ï¸ê®Æ­«ÂÐ!!", vbCritical
    
48.             Exit Sub
    
49.         End If
    
50.     End If
    
51.     ¶}©l²Î­p
    
52. End Sub

½Æ»s¥N½X

¤U¸ü (92.73 KB)

2015-11-18 11:40

s7659109

¶i¶¥°ÝÃD¡G       
        1.·í¿é¤J°Ï¦p¿é¤Je100µ{¦¡·|¥X²{¿ù»~¡A¥i§_¥X²{µøµ¡¤è¦¡ªí²{¡H
        2.¥Ø«e¦C¿é¤J¦Ü18¦C¡Aµ{¦¡¥i§_±±¨î¡A·í¦A¿é¤J§¹¦C19®É¡A¦Û°Ê¦AªÅ¥X1¦C¡A­ì20¦C¦Û°Ê¦V¤U½Õ¾ã1¦C¡A¥H¦¹Ãþ±À!
        3.¬°¦ó¿é¤J°Ï»P¶¶§Ç¦CÃC¦â·|¤£¤@­P¡C

yen956

¦^´_ 15# s7659109
¥H#14F ¬°¨Ò¦^ÂÐ:
Q1. ¦b­Ë¼Æ²Ä4¦C
(§Y¦b49»P50¦C¤§¶¡)
´¡¤J
        On Error Resume Next
        [B2:X18].Find(What:=Target, LookIn:=xlFormulas, LookAt:=xlWhole).Activate
        MsgBox "ª`·N:" & Chr(10) & "¸ê®Æ¿é¤J¿ù»~!!", vbCritical
        Exit Sub
§Y¥i.
Q2. ³o¬Oª©­±³]­p°ÝÃD,
¦ó¤£±N¿é¤J°Ïª½©ñ¨ì¨ì³Ì¤U­±?
¤¤¶¡¦CªÅ¥Õ¦C¥i¼È¥ý穏ÂÃ?
Q3. ¬Ý¤£¥X¿é¤J°Ï»P¶¶§Ç¦CÃC¦â¦³¦ó¤£¤@­P?
¤£¬O¦³°Êµe¹Ï¥i¹ï·Ó¶Ü?

yen956

¦^´_ 15# s7659109
Sorry, Q1 ÁÙ¨S¦³§ä¨ìµª®×, ­ì·Qªk·|¶i¤J¦Û§Ú´`Àô, Sorry!!

s7659109

°ÝÃD3¡G¦³ªþÀÉ(¤u§@ªí1)¶¶2¡B3¡B4½T¹ê¤£¤@­P(office2010)·|¦³®t¶Ü¡H
°ÝÃD2¡G­Õ¦C19¡B20©ñ¨ì³Ì«e­±¡A«á­±³°Äò¼W¥[¡A­ìµ{¦¡½X¬O§_¨ç¬A¦b¤º¡A¦Ó¥i¦æ¡H

yen956

¦^´_ 18# s7659109
°ÝÃD2¡G¨S¿ù, ¥u­n¦bVBA¤¤¬ÛÃö¦ì§}§ï¤@§ï´N¦æ¤F, ¦Ó¥B§Aªº·Qªk(©ñ¨ì³Ì¤W­±)§ó´Î!!
°ÝÃD3¡G¤£¬O2010ªº°ÝÃD, ¦Ó¬O, ¦]¬°¸ê®Æ¿é¤J¿ù»~(¤]´N¬O«e­±ªºQ1°ÝÃD),
§Ú¤]¤£ª¾¹D­n¦p¦ó§ï,
¥Ø«e·Q¨ìªº¬O§ï¥Î CommandButton(³Q°Ê°õ¦æ),
¤£­n¥Î Worksheet_Change(¦Û°Ê°õ¦æ)¤~¤£·|±¼¶i¦Û§Ú´`Àô¤¤,
¥t½Ð°ª©ú§a, Sorry!!

yen956

¦^´_ 13# s7659109
¸Õ¸Õ¬Ý:
§Ú¸Õ¹L¦n¹³¨S°ÝÃD
ÁÙ¬OªºÀÉ, °ÝÃD40-¼Ð¥Ü-1.rar, ¦ýb21,c21 ¦³§ï
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Rng As Range, Cel As Range
    Set Rng = Application.Union([B21:C21], [G20:L20])
    If Intersect(Target, Rng) Is Nothing Then Exit Sub
    If Not Intersect(Target, [B21:C21]) Is Nothing Then
        [B2:X18].Interior.ColorIndex = xlNone
        [G20:L20].Interior.ColorIndex = xlNone
        [G21:L21] = ""
        If [B21] > [C21] Then
            MsgBox "ª`·N:" & Chr(10) & "±Ò©l¦Cªº­È ¤£¥i¥H¤j©ó ²×¤î¦Cªº­È", vbCritical
            Exit Sub
        End If
    End If
    Set Rng = Range("B" & [B21] & ":X" & [C21] & "")
    If Not Intersect(Target, [G20:L20]) Is Nothing Then
        [B2:X18].Interior.ColorIndex = xlNone
        [G20:L20].Interior.ColorIndex = xlNone
        [G21:L21] = ""
        On Error Resume Next
        Set Cel = Rng.Find(What:=Target, LookIn:=xlFormulas, LookAt:=xlWhole)
        If Cel Is Nothing Then
            MsgBox "ª`·N:" & Chr(10) & "¸ê®Æ¿é¤J¿ù»~!!", vbCritical
            Exit Sub
        End If
        [N21] = "= COUNTA(G20:L20)"
        If [N21] <> 6 Then Exit Sub
        [N20] = "=SUMPRODUCT((G20:L20<>"""")/COUNTIF(G20:L20,G20:L20&""""))"
        If [N20] < 6 Then
            MsgBox "ª`·N:" & Chr(10) & "¿é¤J°Ï¸ê®Æ­«ÂÐ!!", vbCritical
            Exit Sub
        End If
    End If
    ¶}©l²Î­p
End Sub