ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

°Ï°ì¤ºÅã¥Ü¿é¤J­È¶ñº¡ÃC¦â¤§°ÝÃD

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

TOP

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

TOP

­ã¤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

°ÝÃD40-¼Ð¥Ü-1.rar (16.24 KB)

§Æ±æ¤ä«ù!

TOP

¸Õ¸Õ¬Ý:
  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. Private Sub Worksheet_Change(ByVal Target As Range)
  26.     Dim Rng As Range
  27.     Set Rng = Application.Union([B21:C21], [G20:L20])
  28.     If Intersect(Target, Rng) Is Nothing Then Exit Sub
  29.     If Not Intersect(Target, [B21:C21]) Is Nothing Then
  30.         [B2:X18].Interior.ColorIndex = xlNone
  31.         [G20:L20].Interior.ColorIndex = xlNone
  32.         [G21:L21] = ""
  33.         If [B21] > [C21] Then
  34.             MsgBox "ª`·N:" & Chr(10) & "±Ò©l¦Cªº­È ¤£¥i¥H¤j©ó ²×¤î¦Cªº­È", vbCritical
  35.             Exit Sub
  36.         End If
  37.     End If
  38.     If Not Intersect(Target, [G20:L20]) Is Nothing Then
  39.         [B2:X18].Interior.ColorIndex = xlNone
  40.         [G20:L20].Interior.ColorIndex = xlNone
  41.         [G21:L21] = ""
  42.         [N21] = "= COUNTA(G20:L20)"
  43.         If [N21] <> 6 Then Exit Sub
  44.         [N20] = "=SUMPRODUCT((G20:L20<>"""")/COUNTIF(G20:L20,G20:L20&""""))"
  45.         If [N20] < 6 Then
  46.             MsgBox "ª`·N:" & Chr(10) & "¿é¤J°Ï¸ê®Æ­«ÂÐ!!", vbCritical
  47.             Exit Sub
  48.         End If
  49.     End If
  50.     ¶}©l²Î­p
  51. End Sub
½Æ»s¥N½X
test.gif

TOP

¶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

°ÝÃD40-¼Ð¥Ü-¶i¶¥.rar (22.01 KB)

§Æ±æ¤ä«ù!

TOP

¦^´_ 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¹ï·Ó¶Ü?

TOP

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

TOP

°ÝÃ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
§Æ±æ¤ä«ù!

TOP

¦^´_ 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!!

TOP

¦^´_ 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

TOP

        ÀR«ä¦Û¦b : µoµÊ®ð¬Oµu¼ÈªºµoºÆ¡C
ªð¦^¦Cªí ¤W¤@¥DÃD