Andy2483

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

°õ¦æ«e:

¤U¸ü (109 KB)

2023-4-12 15:19

°õ¦æµ²ªG:

¤U¸ü (124.59 KB)

2023-4-12 15:20

Option Explicit
Sub TEST()
Dim Brr, Y, i&, j&, N&, T$, T1$, Ma%
Dim xR As Range, Ra As Range, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = ActiveSheet: [Q:IA].ClearContents
Set xR = Range(Sh.[IA5], Sh.Cells(Rows.Count, "B").End(3))
Brr = xR
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): If T1 = "" Then GoTo i01
   For j = 2 To 14
      T = Brr(i, j): If T = "" Then GoTo i02
      If InStr(T, "A") Then
         T = Format(Mid(T, 2), "A" & "000")
         If Y(T) = "" Then
            N = N + 1: Brr(N, 16) = T
            Y(T) = N: Y(T & "/c") = 17
            Else
               Y(T & "/c") = Y(T & "/c") + 1
               If Ma < Y(T & "/c") Then Ma = Y(T & "/c")
         End If
         Brr(Y(T), Y(T & "/c")) = T1
      End If
i02:
   Next
i01:
Next
With [B5].Resize(UBound(Brr), Ma + 16)
   .Value = Brr
   With Intersect(.Cells, .Cells.Offset(0, 15))
      .Sort KEY1:=.Item(1), Order1:=1, Header:=2
      For i = 1 To N: .Item(i, 1) = "A" & Val(Mid(.Item(i, 1), 2)): Next
   End With
End With
Set Y = Nothing: Set xR = Nothing: Set Sh = Nothing: Erase Brr
End Sub