Andy2483

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

°õ¦æµ²ªG:

¤U¸ü (178.87 KB)

2023-4-21 11:17

Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Brr, Crr, Y, Z, R&, C&, i&, j&, T$
Dim xR As Range, Sh As Worksheet
ReDim Crr(1 To 1000, 1 To Columns.Count - 1)
For Each Sh In Sheets
   If InStr(Sh.Name, "¯¸") = 1 Then
      Set xR = Intersect(Sh.UsedRange, Sh.[U:Y]): Brr = xR
      For C = 1 To UBound(Brr, 2)
         If Brr(1, C) = "" Then GoTo i01 Else: j = j + 1: i = 0
         For R = 1 To UBound(Brr)
            T = Brr(R, C)
            If R = 1 Then T = Left(T, 3) & Format(Mid(T, 4), "00")
            If T <> "" Then i = i + 1: Crr(i, j) = T
         Next
         If i > Z Then Z = i
i01:  Next
   End If
Next
With Sheets("·JÁ`").[A1].Resize(Z, j)
   .CurrentRegion.Clear
   .Value = Crr
   .Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=2
   For C = 1 To j
      Intersect(.Cells, .Item(C).EntireColumn).Sort _
      Key1:=.Item(C), Order1:=1, Header:=1, Orientation:=1
   Next
End With
Set Sh = Nothing: Set xR = Nothing: Erase Brr, Crr
End Sub