¦p¦ó±N¤£¦P¸ê®Æ¥Î¤£¦PÃC¦â°Ï¤À?

minarabbit

³Ìªñ±ß½ú¦]·~°È¤W­n³B²z¤jµ§¾Ç¥Í³ø¦W¸ê®Æ¡A¾Ç¥Í·|¿ï¶ñ³\¦h§ÓÄ@¡A
¤@¦ì¾Ç¥Í¥i¯à·|¦³±Nªñ5µ§ªº¸ê®Æ(³ø¦W¤£¦P¬ì¨t)¡A©Ò¥HÁ`­p°_¨Ó·|¦³±Nªñ¤dµ§ªº¸ê®Æ¡C
¬°¤F¤è«K¦b¹q¸£¤W©Î¯È¥»¤WÀˮָê®Æ¡A·|§â¦P¤@¦ì¾Ç¥Íªº¸ê®Æ¥ÎÃC¦â°Ï¤À(¦pªþ¥ó¤º¹Ï¤ù3)¡C
±ß½ú¤Wºô¬d¸ß³\¦h¸ê®Æ¡A¤j¦h¼Æ³£¬O«Øij¥Î"³]©w®æ¦¡¤Æªº±ø¥ó"¥h³B²z¡A¦ýµ²ªG·|¦pªþ¥ó¤º¹Ï¤ù4ªº±¡ªp¡C
«á¨Ó§ä¨ì°ê¥~¦³¤H°µ¥X¤FVBAµ{¦¡¡A¥i¥H±N¬Û¦P¸ê®Æ¥ÎÃC¦â°Ï¤À¡A¦h­Ó¸ê®Æ¥i¥H°Ï¤À¶}¨Ó(¦pªþ¥ó°ê¥~VBAµ{¦¡)¡C
¦ý¬O·í±ß½ú´ú¸Õ®É¡A·|¥X²{¥H¤U2ºØ±¡§Î:
1. ¥þ¿ï¸ê®Æ«á¡Aµ{¦¡·|¶¶§Q¶]§¹¡A¦ý¸ê®ÆÃC¦â¥X²{²V¶Ã¡A¦pªþ¥ó¹Ï¤ù1ªº±¡§Î¡C
2. «ü©w¨­¤ÀÃÒÄæ¦ì«á¡Aµ{¦¡©MExcel¥d¦í¡A¦pªþ¥ó¹Ï¤ù2ªº±¡§Î¡C

±ß½ú§Æ±æ¦U¦ìVBA°ª¤â¯à¸ÑµªºÃ´b¡A¯à§_¦pªþ¥ó¹Ï¤ù3°µÃC¦â°Ï¤À¡AÃC¦â¯à°÷¤£¶Ë²´¡A¥B¦P¤@¦ì¾Ç¥Í¸ê®Æ±Ä¥Î¤@¦â¡A
ÃC¦â°Ï¤À³Ì¦h4ºØÃC¦â¡A«ö·Ó¶¶§Ç±N¾Ç¥Í¸ê®Æ°µ¤ÀÃþ¡A·PÁ¦U¦ì°ª¤â±Ð¾É»P¦^´_¡C

­ã´£³¡ªL

Sub TEST_A1()
Dim xR As Range, xH As Range, Cr, x%
Cr = Array(44, 37, 39, 43) '¦â¸¹¥Î"¿ý»s"§Y¥i¨ú±o
With Range([f2], [a65536].End(3))
     .Interior.ColorIndex = xlNone
     Application.ScreenUpdating = False
     For Each xR In .Columns(4).Cells
         If xR <> xR(0) Then Set xH = xR(1, 0)
         If xR <> xR(2) Then
            Range(xH, xR).Interior.ColorIndex = Cr(x)
            x = x + 1: If x = 4 Then x = 0
         End If
     Next
End With
End Sub

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

minarabbit

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

  ÁÂÁ­㴣³¡ªL¤j¤j! §Ö³t¦a¸Ñ¨M¤F¦hµ§¸ê®Æ¤ÀÃC¦âªº°ÝÃD!
  ©M¦P¨Æ¤@°_¬ã¨s¤j¤j¼gªºµ{¦¡¡AÁöµM¦³¨Ç¤ñ¸û±M·~ªº»yªk¬Ý¤£À´¡A
  ¦ý¸g¹LAndy2483«e½ú¥[¤Wµù¸Ñ¡A§Ú©M¦P¨Æ¥i¥H¦b©m¦W©M¨­¤ÀÃÒÄæ¦ìÅÜ°Ê«á
  ¤´¥i¥H¶¶§Q¦a¹B¦æµ{¦¡¡A¦Ó¥BÁÙ¯à§â­ì¥»4ºØÃC¦â¼W¥[¨ì6ºØ¡A³oºØ¾Ç²ßªºÅå³ß¥O§Ú·P¨ìµL¤ñ§Ö¼Ö!!

  ¦A¦¸·PÁ­㴣³¡ªL¤j¤jªº±Ð¾É¡A¨Ã·PÁÂAndy2483«e½ú¤À¨Éª¾ÃÑ¡C

minarabbit

¦^´_ 3# Andy2483


    ·PÁÂAndy2483«e½ú¤À¨É¡A±zªºµù¸Ñ¹ï·Q¾Ç²ßªº§ÚÀ°§U«Ü¤j¡A¥O§ÚÅå³Yªº¬O±z«á­±ÁÙ¼g¤F¦n¦hµ{¦¡¡A¶Ô¾Çªººë¯«¥O±ß½ú¨ØªA¡C

­ã´£³¡ªL

¤W¤@­Ó¬O"³v¦æ"¶ñ¦â, ¸ûºC//
³o­Ó¬O"¤À°Ï"¶ñ¦â, ·í¸ê®Æ¸û¦h®É, ²z½×¤W·|¸û§Ö!!!
Sub TEST_A2()
Dim Arr, i&, R&, N&, S$, T$, x%, xA As Range, U(1 To 4) As Range
Cr = Array(0, 44, 37, 39, 43)
With Range([f2], [a65536].End(3)(2))
     .Interior.ColorIndex = xlNone
     Arr = .Value
End With
For i = 1 To UBound(Arr) - 1
    S = Arr(i, 4)
    If S <> T Then T = S: R = i + 1: N = 0
    N = N + 1
    If S <> Arr(i + 1, 4) Then
       x = x Mod 4 + 1: Set xA = Cells(R, "c").Resize(N, 2)
       If U(x) Is Nothing Then Set U(x) = xA Else Set U(x) = Union(U(x), xA)
       If U(x).Count > 100 Then U(x).Interior.ColorIndex = Cr(x): Set U(x) = Nothing
    End If
Next i
For x = 1 To 4
    If Not U(x) Is Nothing Then U(x).Interior.ColorIndex = Cr(x)
Next x
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