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

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

µ{¦¡½X¶K¤W¡A¥X²{¤U­zµe­±!

°Ï°ì.png (66.84 KB)

°Ï°ì.png

§Æ±æ¤ä«ù!

TOP

¸Õ¸Õ¬Ý(§¹¾ãª©):
  1. Option Explicit
  2. Sub ¶}©l²Î­p()
  3.     Dim Cel As Range, Rng As Range
  4.     Dim FstAddr As String
  5.     Dim ndx As Integer, i As Integer, cNum As Integer
  6.     Set Rng = Range("B" & [B3] & ":X" & [C3] & "")   '³]©w±Ò©l¦C»P²×¤î¦C¤§¶¡ªº ¤p·j´M½d³ò
  7.     '¥ý·j´M¤j½d³ò
  8.     For Each Cel In [G2:L2]
  9.         On Error Resume Next         '©¿²¤¿ù»~Ä~Äò°õ¦æ VBA ¥N½X, ÁקK¥X²{¿ù»~®ø®§
  10.         Set Cel = [B5:X21].Find(What:=Cel, LookIn:=xlFormulas, LookAt:=xlWhole)   '³]©w[B5:X21]¬°·j´M½d³ò
  11.         If Cel Is Nothing Then
  12.             MsgBox "ª`·N:" & Chr(10) & "¸ê®Æ¿é¤J¿ù»~!!", vbCritical
  13.             Exit Sub
  14.         End If
  15.     Next
  16.     '¦A·j´M¤p½d³ò
  17.     Set Rng = Range("B" & [B3] & ":X" & [C3] & "")   '³]©w±Ò©l¦C»P²×¤î¦C¤§¬°·j´M½d³ò
  18.     Rng.Select
  19.     For i = 7 To 10
  20.         With Selection.Borders(i)
  21.             .LineStyle = xlContinuous
  22.             .Weight = xlMedium
  23.         End With
  24.     Next
  25.     For Each Cel In [G2:L2]
  26.         Cel.Activate
  27.         cNum = Cel.Offset(-1, 0).Interior.ColorIndex
  28.         Cel.Interior.ColorIndex = cNum
  29.         ndx = 0
  30.         On Error Resume Next         '©¿²¤¿ù»~Ä~Äò°õ¦æ VBA ¥N½X, ÁקK¥X²{¿ù»~®ø®§
  31.         Rng.Find(What:=Cel, LookIn:=xlFormulas, LookAt:=xlWhole).Activate
  32.         If ActiveCell.Address = Cel.Address Then GoTo next1   '¦pªG­ì¦a½ñ´N¬O§ä¤£¨ì
  33.         '¦pªG¦³§ä¨ì, ... ...
  34.         ActiveCell.Interior.ColorIndex = cNum
  35.         FstAddr = ActiveCell.Address
  36.         Do
  37.             ndx = ndx + 1
  38.             Rng.FindNext(After:=ActiveCell).Activate    'Ä~Äò§ä¤U¤@­Ó
  39.             ActiveCell.Interior.ColorIndex = cNum
  40.         Loop Until FstAddr = ActiveCell.Address         'ª½¨ì¦^¨ì²Ä¤@¦¸§ä¨ìªºÀx¦s®æ
  41. next1:
  42.         Cel.Offset(1, 0) = ndx    '²Î­p­È¼g¤J ndx, ´«¤U¤@®æ
  43.     Next
  44. End Sub

  45. Sub ²M°£©³¦â_®æ½u¤Î²Î­pµ²ªG()
  46.     Dim i As Integer
  47.     [B5:X21].Select
  48.     For i = 3 To 4
  49.         Selection.Borders(i).LineStyle = xlNone
  50.     Next
  51.     For i = 7 To 10
  52.         Selection.Borders(i).LineStyle = xlNone
  53.     Next
  54.     Selection.Interior.ColorIndex = xlNone
  55.     [G3:L3] = ""
  56. End Sub

  57. Private Sub Worksheet_Change(ByVal Target As Range)    'Target´N¬O¿W°Ê Worksheet_Change ªºRange
  58.     Dim Rng As Range, Cel As Range
  59.     Set Rng = Application.Union([B3:C3], [G2:L2])   '³]©w §PÂ_±ø¥ó ¤Î¿é¤J°Ï ¬°¿W°Ê Worksheet_Change ªº½d³ò
  60.     If Intersect(Target, Rng) Is Nothing Then Exit Sub   '¦pªG¤£¦b¿W°Ê½d³ò, Â÷¶}
  61.     If Target.Count > 1 Then Exit Sub       '¤@¦¸§ïÅܤӦh®æ, Â÷¶}
  62.     ²M°£©³¦â_®æ½u¤Î²Î­pµ²ªG
  63.     If Not Intersect(Target, [B3:C3]) Is Nothing Then   '¦pªG¿W°Ê½d³ò¬° §PÂ_±ø¥ó°Ï
  64.         If [B3] > [C3] Then      '¦pªG ±Ò©l¦Cªº­È ¤j©ó ²×¤î¦Cªº­È
  65.             MsgBox "ª`·N:" & Chr(10) & "±Ò©l¦Cªº­È ¤£¥i¥H¤j©ó ²×¤î¦Cªº­È!!", vbCritical
  66.             Exit Sub
  67.         End If
  68.     End If
  69.     If WorksheetFunction.CountA([G2:L2]) < 6 Then Exit Sub    '¦pªG¿é¤J°Ï¥¼º¡6®æ, Â÷¶}
  70.     [N2] = "=SUMPRODUCT((G2:L2<>"""")/COUNTIF(G2:L2,G2:L2&""""))"   '­pºâ[G2:L2]ªº¤£­«ÂЮ榳´X®æ
  71.     If [N2] < 6 Then        '¦pªG¤£­«ÂЮ椣¨ì6®æ(ª`·N¿é¤J°Ï¤wº¡6®æ), ĵ§i¨ÃÂ÷¶}
  72.         MsgBox "ª`·N:" & Chr(10) & "¿é¤J°Ï¸ê®Æ­«ÂÐ!!", vbCritical
  73.         Exit Sub
  74.     End If
  75.     ¶}©l²Î­p
  76. End Sub
½Æ»s¥N½X
test.gif
Åã¥Ü¿é¤J­È¶ñº¡ÃC¦â.rar (19.08 KB)

TOP

ÁÂÁ¡AÁÙº¡§¹¾ã¡A¦ý³Ì«á¤@­Ó½Ð¨D¡G
1.­Õ¦C¼Æ¦A¼W¥[(¦p¦A¼W100¦C¡A¬Æ¦Ü1000¦C¡A¬Æ¦Ü¦C¦Û°Ê¼W¥[®É¡A·j´M¦C¼Æ¦Û°Ê¸òµÛ¼W¥[¡A¨Ã«Øijªí³æ¿ï¶µ®³±¼¡A¦]¦C¼Æ¤jªø®É¡A¹ê¦b¤£¦n¥Î)¦p¦ó½Õ¾ã¡C
2.·j´M°Ï°ì¼W¥[¬°2°Ï

1041119Åã¥Ü¿é¤J­È¶ñº¡ÃC¦â.rar (14.6 KB)

§Æ±æ¤ä«ù!

TOP

¦^´_ 23# s7659109
Sorry, ¤ÓÃø¤F!!

TOP

ÁÂÁÂyen956§V¤O¨ì¦¹¡A¦ýÁÙ¬O§Æ±æ¦³¤HÀ°¦£³Ì«á´£¥Xªº°ÝÃD!
§Æ±æ¤ä«ù!

TOP

¦^´_ 25# s7659109
(³o¤@¨â¤Ñ¦Ñ¬O¦^¿ù¥DÃD, ³s¶K¨â¦¸³£¶K¿ù¦a¤è, ¯u©_©Ç!),
¸g­ã¤j¦A¤T«ü¥¿«á, Á`ºâ§¹¦¨¤F!!
¸Õ¸Õ¬Ý:
  1. Option Explicit
  2. Public inAllNum As Integer
  3. Public inNowNum As Integer

  4. Function BigRng() As Range
  5.     Dim rL As String, I As Integer
  6.     rL = Split([B5].End(xlToRight).Address, "$")(1)
  7.     Set BigRng = Range("B5:" & rL & [B5].End(xlDown).Row & "")
  8.     BigRng.Select
  9.     Selection.Interior.ColorIndex = xlNone    '²M°£©³¦â
  10.     For I = 1 To 4
  11.         Selection.Borders(I).LineStyle = xlNone   '²M°£®æ½u
  12.     Next
  13. '    For I = 7 To 10
  14. '        Selection.Borders(I).LineStyle = xlNone
  15. '    Next
  16. End Function

  17. Function SmallRng() As Range
  18.     Dim rL As String, I As Integer
  19.     rL = Split([B5].End(xlToRight).Address, "$")(1)
  20.     Set SmallRng = Range("B" & [D2] & ":" & rL & [D3] & "")    '³]©w±Ò©l¦C»P²×¤î¦C¤§¬°·j´M½d³ò
  21. End Function

  22. Function inputRng() As Range
  23.     Dim rL As String, cNumAr
  24.     Dim str1 As String, I As Integer
  25.     cNumAr = Array(4, 6, 7, 8, 15, 17, 19, 20, 22, 24, 33, 35, 36, 37, 39, 40)  '¬D¿ï²L¦â¨t
  26.     Rows("1:3").Interior.ColorIndex = xlNone     '²M°£¿é¤J°Ï©³¦â
  27.     rL = Split([G1].End(xlToRight).Address, "$")(1)
  28.     Range("G3:" & rL & "3") = ""    '²M°£²Î­pµ²ªG
  29.     inAllNum = [G1].End(xlToRight).Column - 6    '¿é¤J°Ï¦@¦³´X®æ
  30.     inNowNum = [G2].End(xlToRight).Column - 6    '¥Ø«e¤w¸g¿é¤J´X®æ
  31.     [F1].FormulaR1C1 = "=SUMPRODUCT((R[1]C[1]:R[1]C[" & inAllNum & "]<>"""")/COUNTIF(R[1]C[1]:R[1]C[" & inAllNum & "],R[1]C[1]:R[1]C[" & inAllNum & "]&""""))"
  32.     For I = 7 To 6 + inAllNum
  33.         Cells(1, I).Resize(3).Interior.ColorIndex = cNumAr(I - 7)
  34.     Next
  35.     str1 = "G2:" & rL & "2"
  36.     Set inputRng = Range(str1)
  37. End Function

  38. Sub ¶}©l²Î­p()
  39.     Dim inRng As Range, bRng As Range, sRng As Range
  40.     Dim Rng As Range, Cel As Range
  41.     Dim FstAddr As String
  42.     Dim ndx As Integer, cNum As Integer
  43.     Set bRng = BigRng
  44.     Set sRng = SmallRng
  45.     Set inRng = inputRng
  46.    
  47.     '¥ý·j´M¤j½d³ò
  48.     For Each Cel In inRng
  49.         If Cel = "" Then Exit For
  50.         On Error Resume Next         '©¿²¤¿ù»~Ä~Äò°õ¦æ VBA ¥N½X, ÁקK¥X²{¿ù»~®ø®§
  51.         Set Cel = bRng.Find(What:=Cel, LookAt:=xlWhole)   '¦b¤j½d³ò¤¤·j´M
  52.         If Cel Is Nothing Then
  53.             MsgBox "ª`·N:" & Chr(10) & "¸ê®Æ¿é¤J¿ù»~!!" & Chr(10) & "½Ð­×¥¿!!", vbCritical
  54.             Exit Sub
  55.         End If
  56.     Next
  57.     '¦A·j´M¤p½d³ò
  58.     For Each Cel In inRng
  59.         Cel.Activate
  60.         cNum = Cel.Interior.ColorIndex
  61.         ndx = 0
  62.         On Error Resume Next         '©¿²¤¿ù»~Ä~Äò°õ¦æ VBA ¥N½X, ÁקK¥X²{¿ù»~®ø®§
  63.         sRng.Find(What:=Cel, LookAt:=xlWhole).Activate
  64.         If ActiveCell.Address = Cel.Address Then GoTo next1   '¦pªG­ì¦a½ñ´N¬O§ä¤£¨ì
  65.         '¦pªG¦³§ä¨ì, ... ...
  66.         ActiveCell.Interior.ColorIndex = cNum
  67.         FstAddr = ActiveCell.Address
  68.         Do
  69.             ndx = ndx + 1
  70.             sRng.FindNext(After:=ActiveCell).Activate   'Ä~Äò§ä¤U¤@­Ó
  71.             ActiveCell.Interior.ColorIndex = cNum
  72.         Loop Until FstAddr = ActiveCell.Address         'ª½¨ì¦^¨ì²Ä¤@¦¸§ä¨ìªºÀx¦s®æ
  73. next1:
  74.         Cel.Offset(1, 0) = ndx    '²Î­p­È¼g¤J ndx, ´«¤U¤@®æ
  75.     Next
  76. End Sub
  77. Private Sub CommandButton1_Click()
  78.     Dim Rng As Range, inRng As Range, bRng As Range, sRng As Range
  79.     Dim I As Integer
  80.     Set bRng = BigRng
  81.     Set sRng = SmallRng
  82.     Set inRng = inputRng
  83.    
  84.     If Val([D2]) < 5 Then
  85.         MsgBox "ª`·N:" & Chr(10) & "§PÂ_±ø¥óªº±Ò©l¦Cªº­È ¤£¥i¤p©ó 5!!", vbCritical
  86.         Exit Sub
  87.     End If
  88.     If Val([D3]) > [B5].End(xlDown).Row Then
  89.         MsgBox "ª`·N:" & Chr(10) & "§PÂ_±ø¥óªº²×¤î¦Cªº­È ¤£¥i¤j©ó" & [B5].End(xlDown).Row & "!!", vbCritical
  90.         Exit Sub
  91.     End If
  92.     If Val([D2]) > Val([D3]) Then      '¦pªG ±Ò©l¦Cªº­È ¤j©ó ²×¤î¦Cªº­È
  93.         MsgBox "ª`·N:" & Chr(10) & "±Ò©l¦Cªº­È ¤£¥i¥H¤j©ó ²×¤î¦Cªº­È!!", vbCritical
  94.         Exit Sub
  95.     End If
  96.     If inNowNum < inAllNum Then
  97.         MsgBox "ª`·N:" & Chr(10) & "¿é¤J°Ï©|¥¼¶ñ满«e," & Chr(10) & "½Ð¤Å«ö¡i¶}©l²Î­p¡j!!", vbCritical
  98.         Exit Sub     '¦pªG¿é¤J°Ï¥¼º¡®æ, Â÷¶}
  99.     End If
  100.     If Val([F1]) < inNowNum Then
  101.         MsgBox "ª`·N:" & Chr(10) & "¿é¤J°Ïªº­È­«ÂÐ," & Chr(10) & "½Ð­×¥¿!!", vbCritical
  102.         Exit Sub
  103.     End If
  104.     ¶}©l²Î­p
  105.     SmallRng.Select
  106.     For I = 7 To 10
  107.         With Selection.Borders(I)      'µe®æ½u
  108.             .LineStyle = xlContinuous
  109.             .Weight = xlMedium
  110.         End With
  111.     Next
  112. End Sub
½Æ»s¥N½X
  
Åã¥Ü¿é¤J­È¶ñº¡ÃC¦â2.rar (28.32 KB)

TOP

test.gif

TOP

¤S¦³¶i¶¥°ÝÃD½Ð±Ð¡A¤À¬°¿é¤J°Ï»PÅã¥Ü°Ï¡A¨ä¥L¥\¯à
¦n¥Î½Ð«O«ù¡C

Åã¥Ü¿é¤J­È¶ñº¡ÃC¦â-¶i¶¥°ÝÃD1041126.rar (24.15 KB)

§Æ±æ¤ä«ù!

TOP

        ÀR«ä¦Û¦b : ±o²z­nÄǤH¡A²zª½­n®ð©M¡C
ªð¦^¦Cªí ¤W¤@¥DÃD