Andy2483

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


    ÁÂÁ½׾Â,ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
ÁÂÁ ­ã´£³¡ªL«e½úªº¤è®×±`¥Î¤£¦Pªº¤èªk¸Ñ¨M,«á¾Ç¦pÀò¦ÜÄ_
¥H¤U¬O¤è®×¾Ç²ß¤ß±oµù¸Ñ,½Ð«e½ú¦A«ü¾É

°õ¦æ«e:

¤U¸ü (141.63 KB)

2023-6-13 12:37

°õ¦æµ²ªG:

¤U¸ü (141.61 KB)

2023-6-13 12:37

Option Explicit
Sub TEST_A1()
Dim xR As Range, xH As Range, Cr, x%
'¡ô«Å§iÅܼÆ
Cr = Array(44, 37, 39, 43) '¦â¸¹¥Î"¿ý»s"§Y¥i¨ú±o
'¡ô¥OCrÅܼƬO ¤@ºû°}¦C(4­Ó°}¦C­È:¯Á¤Þ¸¹0~3)
With Range([f2], [a65536].End(3))
'¡ô¥H¤U¬OÃö©ó ¥»ªíÀx¦s®æªºµ{§Ç
     .Interior.ColorIndex = xlNone
     '¡ô¥OÀx¦s®æ©³¦â¬OµL¦â
     Application.ScreenUpdating = False
     '¡ô¥O¿Ã¹õµe­±¤£ÀHµ{§Ç°õ¦æµ²ªG°µÅܤÆ
     For Each xR In .Columns(4).Cells
     '¡ô³]³v¶µ°j°é!¥OxRÅܼƬO ¸Ó½d³ò²Ä4ÄæÀx¦s®æ
         If xR <> xR(0) Then Set xH = xR(1, 0)
         '¡ô¦pªGxRÀx¦s®æ­È¤£µ¥©ó¤W¤@®æÀx¦s®æ­È!
         '´N¥OxHÅܼƬOxRªº¥ªÃ䪺Àx¦s®æ
         If xR <> xR(2) Then
         '¡ô¦pªG°j°é¶]¨ì xRÀx¦s®æ­È¤£µ¥©óxRªº¤U­ÓÀx¦s®æ­È
            Range(xH, xR).Interior.ColorIndex = Cr(x)
            '¡ô´N¥OxH»PxR³o½d³òÀx¦s®æªº©³¦â¤W¦â
            x = x + 1: If x = 4 Then x = 0
            '¡ô¥OXÅܼƱq0~3°µ´`ÀôÅܤÆ
         End If
     Next
End With
End Sub

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æµ²ªG:

¤U¸ü (139.4 KB)

2023-6-13 13:21

Option Explicit
Sub TEST()
Dim Brr, A, Z, i&, N&, T$, T3$, T4$, xR As Range, K%
A = Array(37, 40, 38, 35)
'A = Array(37, 40, 38, 35, 36, 34) '¥i¦Û¦æ¼W¥[ÃC¦â
Set Z = CreateObject("Scripting.Dictionary")
[Á`ªí!C:D].Interior.ColorIndex = xlNone
Set xR = Range([Á`ªí!F1], [Á`ªí!A65536].End(3)): Brr = xR
For i = 2 To UBound(Brr)
   T3 = Brr(i, 3): T4 = Brr(i, 4): T = Brr(i, 1) & "|" & Brr(i, 2) & "|" & T3
   If Z(T4) = "" Then Z(T4) = T
   If Z(T) = "" Then Z(T) = T4
   If i - Z(T4 & "|") = 1 Or Z(T4 & "|") = "" Then Z(T4 & "|") = i Else: K = 1
   If Z(T4) <> T Then MsgBox "ID_" & T4 & " ¸ê®Æ²§±`": Exit Sub
   If Z(T) <> T4 Then MsgBox "®Õ¥Í_" & T & "  ID²§±`": Exit Sub
   T = T3 & "|" & T4
  If Z(T) = "" Then N = N + 1: Z(T) = A((N - 1) Mod (UBound(A) + 1))
   xR(i, 3).Resize(, 2).Interior.ColorIndex = Z(T)
Next
If K = 1 Then MsgBox "¸ê®Æ¹s´²!«Øij­«·s±Æ§Ç!"
Set Z = Nothing: Set xR = Nothing: Erase Brr, A
End Sub

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¬° ¦U®Õ²Î­p

°õ¦æµ²ªG:

¤U¸ü (24.22 KB)

2023-6-13 15:09

Option Explicit
Sub TEST_1()
Application.DisplayAlerts = False
Dim Brr, A%, B$, Z, i&, R&, T$, T2$, T3$, xR As Range
Set Z = CreateObject("Scripting.Dictionary")
Set xR = Range([Á`ªí!F1], [Á`ªí!A65536].End(3)): Brr = xR
For i = 2 To UBound(Brr)
   If i = 2 Then R = R + 1: Brr(1, 1) = "®Õ§O\¤H¼Æ": Brr(1, 2) = "¤H¼Æ": Brr(1, 3) = "Remark"
   T2 = Brr(i, 2): T3 = Brr(i, 3): T = T2 & "|" & T3
   If Z(T) <> "" Then: GoTo i01
   If Z(T2) = "" Then
      R = R + 1: Z(T2) = R: Brr(R, 1) = Brr(i, 2)
      Brr(R, 2) = 1: Brr(R, 3) = T3: Z(T) = 1: GoTo i01
   End If
   A = Brr(Z(T2), 2): A = A + 1: Brr(Z(T2), 2) = A
   B = Brr(Z(T2), 3): B = B & "," & T3: Brr(Z(T2), 3) = B
   Z(T) = 1
i01: Next
If R <= 1 Then MsgBox "µL¸ê®Æ!": Exit Sub
On Error Resume Next
Sheets("¦U®Õ²Î­p").Delete
On Error GoTo 0
With Worksheets.Add(after:=Worksheets(Sheets.Count))
   .Name = "¦U®Õ²Î­p"
   With .[A1].Resize(R, 3)
      .Value = Brr: .EntireColumn.AutoFit
   End With
End With
Set Z = Nothing: Set xR = Nothing: Erase Brr
End Sub

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¬° ¤ñ§Ç1©ú²Ó,½Ð¦U¦ì«e½ú«ü±Ð

°õ¦æµ²ªG:

¤U¸ü (31.62 KB)

2023-6-13 16:21

Option Explicit
Sub TEST_2()
Application.DisplayAlerts = False
Dim Brr, Crr, A%, Z, i&, C%, T$, T2$, T3$, T5$, xR As Range, M&
Set Z = CreateObject("Scripting.Dictionary")
Set xR = Range([Á`ªí!F1], [Á`ªí!A65536].End(3)): Brr = xR
ReDim Crr(1 To UBound(Brr), 1 To 200)
For i = 2 To UBound(Brr)
   If i = 2 Then C = C + 1: Crr(1, 1) = "N0\¤ñ§Ç1": Crr(2, 1) = 1
   T2 = Brr(i, 2): T3 = Brr(i, 3): T5 = Brr(i, 5): T = T3 & "|" & T5
   If Z(T) <> "" Then: GoTo i01
   If Z(T5) = "" Then
      C = C + 1: Z(T5) = C: Crr(1, C) = T5: Crr(2, C) = Brr(i, 4) & "/" & T3
      Z(T) = 1: Z(T5 & "|r") = 2: GoTo i01
   End If
   A = Z(T5 & "|r"): A = A + 1: Crr(A, Z(T5)) = Brr(i, 4) & "/" & T3
   Z(T5 & "|r") = A: Z(T) = 1
   If M < A Then M = A: Crr(M, 1) = M - 1
i01: Next
If C <= 1 Then MsgBox "µL¸ê®Æ!": Exit Sub
On Error Resume Next
Sheets("¤ñ§Ç1©ú²Ó").Delete
On Error GoTo 0
With Worksheets.Add(after:=Worksheets(Sheets.Count))
   .Name = "¤ñ§Ç1©ú²Ó"
   With .[A1].Resize(M, C)
      .Value = Crr: .EntireColumn.AutoFit
   End With
End With
Set Z = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub
'=====================================
¸É¥R:
¥H¤U¬O¤ñ§Ç2©ú²Ó

°õ¦æµ²ªG:

¤U¸ü (32.16 KB)

2023-6-13 16:33

Sub TEST_3()
Application.DisplayAlerts = False
Dim Brr, Crr, A%, Z, i&, C%, T$, T2$, T3$, T6$, xR As Range, M&
Set Z = CreateObject("Scripting.Dictionary")
Set xR = Range([Á`ªí!F1], [Á`ªí!A65536].End(3)): Brr = xR
ReDim Crr(1 To UBound(Brr), 1 To 200)
For i = 2 To UBound(Brr)
   If i = 2 Then C = C + 1: Crr(1, 1) = "N0\¤ñ§Ç1": Crr(2, 1) = 1
   T2 = Brr(i, 2): T3 = Brr(i, 3): T6 = Brr(i, 6): T = T3 & "|" & T6
   If Z(T) <> "" Then: GoTo i01
   If Z(T6) = "" Then
      C = C + 1: Z(T6) = C: Crr(1, C) = T6: Crr(2, C) = Brr(i, 4) & "/" & T3
      Z(T) = 1: Z(T6 & "|r") = 2: GoTo i01
   End If
   A = Z(T6 & "|r"): A = A + 1: Crr(A, Z(T6)) = Brr(i, 4) & "/" & T3
   Z(T6 & "|r") = A: Z(T) = 1
   If M < A Then M = A: Crr(M, 1) = M - 1
i01: Next
If C <= 1 Then MsgBox "µL¸ê®Æ!": Exit Sub
On Error Resume Next
Sheets("¤ñ§Ç2©ú²Ó").Delete
On Error GoTo 0
With Worksheets.Add(after:=Worksheets(Sheets.Count))
   .Name = "¤ñ§Ç2©ú²Ó"
   With .[A1].Resize(M, C)
      .Value = Crr: .EntireColumn.AutoFit
   End With
End With
Set Z = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub

Andy2483

¦^´_ 9# ­ã´£³¡ªL
¦^´_ 8# minarabbit

ÁÂÁ ­ã´£³¡ªL«e½ú¦A«ü¾É,ÁÂÁ minarabbit«e½ú¦^´_¤@°_¾Ç²ß

«á¾ÇÂǦ¹©«¾Ç²ß«e½úªº¤è®×,¤è®×¾Ç²ß¤ß±oµù¸Ñ¦p¤U,½Ð«e½ú¦A«ü¾É


Option Explicit
Sub TEST_A2()
Dim Arr, Cr, i&, R&, N&, S$, T$, x%, xA As Range, U(1 To 4) As Range
'¡ô«Å§iÅܼÆ:(Arr,Cr)¬O³q¥Î«¬ÅܼÆ,(i,R,N)¬Oªø¾ã¼Æ,(S,T)¬O¦r¦êÅܼÆ,
'x¬Oµu¾ã¼Æ,xA¬OÀx¦s®æÅܼÆ,U¬O¤@ºû°}¦C(°}¦C¸Ì¥u¯à¸ËÀx¦s®æ)
Cr = Array(0, 44, 37, 39, 43)
'¡ô¥OCrÅܼƬO¤@ºû°}¦C,°}¦C¸Ì5­Ó¼Æ­È(¯Á¤Þ¸¹0~4)
With Range([f2], [a65536].End(3)(2))
'¡ô¥H¤U¬OÃö©ó¥»ªí[F2]¨ìAÄ榳¤º®eÀx¦s®æ¤U¤@®æ,³o½d³òÀx¦s®æªºµ{§Ç
     .Interior.ColorIndex = xlNone
     '¡ô³o½d³òÀx¦s®æ©³¦â¬OµL¦â
     Arr = .Value
     '¡ô¥OArr³o³q¥Î«¬ÅܼƬO ¤Gºû°}¦C,¥H½d³òÀx¦s®æ­È±a¤J°}¦C¤¤
End With
For i = 1 To UBound(Arr) - 1
'¡ô³]¶¶°j°é!i±q1 ¨ìArr°}¦CÁa¦V²Ä2¤j¯Á¤Þ¸¹
    S = Arr(i, 4)
    '¡ô¥OS³o¦r¦êÅܼƬO i°j°é¦C²Ä4ÄæArr°}¦C­È
    If S <> T Then T = S: R = i + 1: N = 0
    '¡ô¦pªGSÅܼƭȻP T³o¦r¦êÅܼƤ£¦P? True´N¥OTÅܼƬO SÅܼÆ,
    '¥ORÅܼƬO i°j°é¼Æ+1,¥ONÅܼƬO 0
    N = N + 1
    '¡ô¥ONÅܼƲ֥[ 1
    If S <> Arr(i + 1, 4) Then
    '¡ô¦pªGSÅܼƤ£¦P©ó¤U¤èªºArr°}¦C­È?
       x = x Mod 4 + 1: Set xA = Cells(R, "c").Resize(N, 2)
       '¡ô¥Ox³oµu¾ã¼ÆÅܼƬO x¦Û¨­°£4ªº¾l¼Æ +1 ¼Æ­È,
       '¡ô¥OxA³oÀx¦s®æÅܼƬO ¦P¾Ç¥Í°Ï°ìªºÀx¦s®æ,
       'Cells(R, "c")¬O¦¹°Ï°ìÀx¦s®æ³Ì¥ª¤W¨¤®æ,
       'Resize(N, 2)¬O¦V¤UÂX®iN®æ,¦V¥kÂX®i2®æ
       If U(x) Is Nothing Then Set U(x) = xA Else Set U(x) = Union(U(x), xA)
       '¡ô¦pªG³oU¤@ºû°}¦Cªº²Äx¯Á¤Þ¸¹°}¦C­È¬O ¨S¦³ª«¥ó,
       '¬O´N¥OU¤@ºû°}¦Cªº²Äx¯Á¤Þ¸¹°}¦C­È¬OxA,
       '§_«h(·N«ä¬Ox¸¹°}¦C­È¤w¸g¦³Àx¦s®æ),´N¥OxA(Àx¦s®æ)¯Ç¤Jx¸¹°}¦C­È¸Ì
       If U(x).Count > 100 Then U(x).Interior.ColorIndex = Cr(x): Set U(x) = Nothing
       '¡ô¦pªGx¸¹°}¦C­È¸ÌªºÀx¦s®æ¤j©ó100®æ? ¬O´N¥O¨ä©³¦â¬O¹ïÀ³ªº¦â¸¹,
       'µM«á¥OU¤@ºû°}¦Cªº²Äx¸¹°}¦C­È²MªÅª«¥ó
    End If
Next i
For x = 1 To 4
    If Not U(x) Is Nothing Then U(x).Interior.ColorIndex = Cr(x)
Next x
'¡ô³]¶¶°j°é±N¨C­Ó U¤@ºû°}¦Cªº°}¦C­È(Àx¦s®æ)©³¦â¬O¹ïÀ³ªº¦â¸¹,
'¦¹°j°é¬O³B²z ¤p©óµ¥©ó100®æªº°}¦C­È(Àx¦s®æ)
End Sub