[µo°Ý] VBA_¥[¤J±N¦U¦PÄæ¦ìªº¬Û¦P­È(¥æ¶°­È)¼Ð¥Ü©³¦âªºµ{¦¡½X_2¡C

Airman

VBA_3AC_4_¹ïÀ³¦Cªº¦PÄæ¥æ¶°­È¼Ð¥Ü©³¦â¡C.rar (25.46 KB)

¤U¸ü¦¸¼Æ: 2

2015-12-25 17:40

¥H¤Uµ{¦¡»yªk~½Ð¦A¥[¤J¤@¬q¡J
±N¦U¦PÄæ¦ìªº¬Û¦P­È(¥æ¶°­È)¼Ð¥Ü©³¦âªºµ{¦¡½X¡C
¸Ô²Ó¹Ï¥Ü¦pªþ¥ó¡C
ÁÂÁÂ!

Private Sub CommandButton1_Click()
Dim b As Range, RW, y%
With Sheets(2)
      Sheets(1).Range("J7", "P" & Sheets(2).[R6] + 5).Copy .[J7]
      Application.Goto .Range("T7:T" & .[R7].End(xlDown).Row)  '¤£¥ÎSelect¡Aª½±µ¸õ¿ï¥Ø¼Ð°Ï
      For Each b In Selection
          If b <> "" Then
          If .Range("R" & b.Row) < .[T5] And .Range("R" & b.Row) - 4 > 0 Then
      
          Dim R(1 To 3) As Range, x%, z%, i%, U%
         
          RW = Array(.[T5], .[R6], b(1, -1))
          For x = 1 To 4
          For y = 1 To 3
          For z = 1 To 7
              Set R(1) = .[J6].Cells(RW(y - 1) - x + 1, z)
              Set R(2) = Nothing
              For i = 1 To 3
                  If i <> y Then Set R(2) = .[J6:P6].Offset(RW(i - 1) - x, 0).Find(R(1), Lookat:=xlWhole)
                  If Not R(2) Is Nothing Then R(1).Interior.ColorIndex = Array(4, 6, 8)(y - 1): Exit For
              Next i
          Next z
          Next y
          Next x
          End If
         
          End If
      Next b
      .[A1].Select
End With
End Sub

Airman

¦^´_ 2# ­ã´£³¡ªL

­ã¤j:
¨þ~¨þ~«e¨Ç¤é¤l±z©Ò½ç±Ðªº¤½¦¡©Mµ{¦¡»yªk~¤p§Ì¨ì¤µ¤Ñ¤~®ø¤Æ¾ã²z§¹²¦~¦ý´N¬O¤@­Ó­­¦PÄæ¦ì¤~¼Ð¥Ü©³¦âªº»yªk¤@ª½Âà¤Æ(®M)¤£¹L¨Ó
ÁÂÁ±zªº­@¤ß«ü¾É~´ú¸ÕOK¤F~·P®¦

·s¦~§Ö¼Ö

­ã´£³¡ªL

For z = 1 To 7
¡@¡@Set R(1) = .[J6].Cells(RW(y - 1) - x + 1, z): U = 0
¡@¡@For i = 1 To 3
¡@¡@¡@¡@Set R(2) = Nothing
¡@¡@¡@¡@If i <> y Then Set R(2) = .[J6:P6].Offset(RW(i - 1) - x, 0).Find(R(1), Lookat:=xlWhole)
¡@¡@¡@¡@If Not R(2) Is Nothing Then If R(2).Column = R(1).Column Then U = U + 1
¡@¡@Next i
¡@¡@If Val(U) = 2 Then R(1).Interior.ColorIndex = Array(4, 6, 8)(y - 1)
Next z

¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×¡×
©Î:¡G
For z = 1 To 7
¡@¡@Set R(1) = .[J6].Cells(RW(y - 1) - x + 1, z): U = 0
¡@¡@For i = 1 To 3
¡@¡@¡@¡@If i <> y Then If R(1) = .[J6].Cells(RW(i - 1) - x + 1, z) Then U = U + 1
¡@¡@Next i
¡@¡@If Val(U) = 2 Then R(1).Interior.ColorIndex = Array(4, 6, 8)(y - 1)
Next z