[µo°Ý] ¾î¦¡¸ê®ÆÂà´«¬°ª½¦¡¸ê®Æ_¦U±è¦¸¦W³æ

Andy2483

¦U¦ì«e½ú¦n
«á¾Ç·Q¾Ç²ß¦UºØ¤£¦Pvba¼gªk,½Ð¦U¦ì«e½ú«ü¾É!ÁÂÁÂ
«á¾ÇÂÇ aer«e½úªº¥DÃD½d¨Ò§@¬°ÃD§÷,ÁÂÁ aer«e½ú,¦p¦³«_¥Ç ½Ð¨£½Ì
¤£¦P¥DÃD¥t¶}ÃD§@¾Ç²ß
http://forum.twbts.com/viewthrea ... a=pageD1&page=1
³ø¦WÂàÀÉ.zip ½d¨Ò¦p¤W½×¾ÂÃìµ²

½Ð±N½d¨Ò³B²z¦¨¬°±è¦¸¦W³æ(±è¦¸¾î¦V±Æ§Ç,¦U±è¦W³æ¦U¦Û±Æ§Ç)¦p¤U¹Ï

¤U¸ü (311.72 KB)

2022-12-2 15:25

«á¾Çªºµ{¦¡½X¦p¤U:
Option Explicit
Sub TEST_ª½¦¡±è¦¸¦W³æ()
Dim Arr, Brr, xR, i&, j&, S&, N&, M&, R&, C&
Dim Y, D As Date
Set Y = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
   .Replace What:=" ", Replacement:="", LookAt:=xlPart
   .Sort KEY1:=.Item(1), Order1:=1, Header:=1
   Arr = .Value
   Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
   .Clear
End With
For Each xR In Brr
   If Trim(xR) <> "" Then
      S = InStr(xR, "±è") + 1
      N = InStr(xR, "(")
      D = Mid(xR, S, N - S)
      Y(D) = Trim(xR)
   End If
Next
[Sheet3!A1].Resize(Y.Count, 1) = Application.Transpose(Y.KEYS)
[Sheet3!B1].Resize(Y.Count, 1) = Application.Transpose(Y.ITEMS)
With Sheets("Sheet3").UsedRange
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2
   Brr = .Value
   .Clear
End With
Y.RemoveAll
For i = 1 To UBound(Brr)
   M = M + 1
   Y(Brr(i, 2)) = M
Next
ReDim Brr(1 To UBound(Arr), 1 To Y.Count)
For i = 2 To UBound(Arr)
   For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
         R = Y(Arr(i, j) & "|")
         R = R + 1
         C = Y(Arr(i, j) & "")
         Brr(R, C) = Arr(i, 1)
         Y(Arr(i, j) & "|") = R
      End If
   Next j
Next i
[Sheet3!A1].Resize(1, M) = Application.Transpose(Application.Transpose(Y.KEYS))
[Sheet3!A2].Resize(UBound(Brr), M) = Brr
Application.Goto [Sheet3!A1]
Set Arr = Nothing
Set Arr = Nothing
Set Y = Nothing
End Sub

PS:«á¾Ç¬P´Á¤».¤é¤£¤è«K¦^´_«e½ú,½Ð¨£½Ì,¬P´Á¤@¦­¤W¦^´_

Andy2483

¦^´_ 8# singo1232001


    ÁÙ¬O¥H¤U³o¤èªk,¦b«e¤è±Æ°£­«½Æ?

Option Explicit
Sub TEST_ª½¦¡±è¦¸¦W³æ_20221219_1()
Dim Arr, Brr, xR, i&, j&, S&, N&, M&, R&, C&
Dim Y, D As Date, T$
Set Y = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
   .Replace What:=" ", Replacement:="", Lookat:=xlPart
   .Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=xlTopToBottom
   Arr = .Value
   Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
   .Clear
End With
For Each xR In Brr
   If Trim(xR) <> "" Then
      S = InStr(xR, "±è") + 1
      N = InStr(xR, "(")
      D = Mid(xR, S, N - S)
      Y(D) = xR
   End If
Next
[Sheet3!A2].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.KEYS))
[Sheet3!A1].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.ITEMS))
With Sheets("Sheet3").UsedRange
   .Sort Key1:=.Item(2, 1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   Brr = .Resize(UBound(Arr))
End With
Y.RemoveAll
For i = 1 To UBound(Brr, 2)
   Y(Brr(1, i)) = i
Next
For i = 2 To UBound(Arr)
   For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
         Y(Arr(i, 1) & "|" & Arr(i, j)) = ""
      End If
   Next
Next
For Each xR In Y.KEYS
   If InStr(xR, "|") And Y(xR) = "" Then
      T = Split(xR, "|")(1)
      S = Y(T & "/a") + 1
      Brr(S + 1, Y(T)) = Split(xR, "|")(0)
      Y(T & "/a") = S
      Y(xR) = 1
   End If
Next
[Sheet3!A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Application.Goto [Sheet3!A1]
Set Arr = Nothing
Set Brr = Nothing
Set Y = Nothing
End Sub

Andy2483

¦^´_ 8# singo1232001


    ÁÂÁ«e½ú´£¥Ü
«á¾Ç¸ÕµÛ§â¸ê®Æ³£©ñ¶i¦r¨å¸Ì,¦A­Ë¥X¨Ó¨Ã±Æ°£­«½Æ,¬O«e½ú©Ò´£¥Üªº¤èªk¶Ü?
½Ð«e½ú¦A«ü¾É,ÁÂÁÂ
°õ¦æ¹Lµ{:

¤U¸ü (104.27 KB)

2022-12-19 14:44

µ²ªG:

¤U¸ü (238.86 KB)

2022-12-19 14:45

µ{¦¡½X¦p¤U:

Option Explicit
Sub TEST_ª½¦¡±è¦¸¦W³æ_20221219()
Dim Arr, Brr, xR, i&, j&, S&, N&, M&, R&, C&
Dim Y, D As Date, T$
Set Y = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
   .Replace What:=" ", Replacement:="", Lookat:=xlPart
   .Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=xlTopToBottom
   Arr = .Value
   Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
   .Clear
End With
For Each xR In Brr
   If Trim(xR) <> "" Then
      S = InStr(xR, "±è") + 1
      N = InStr(xR, "(")
      D = Mid(xR, S, N - S)
      Y(D) = xR
   End If
Next
[Sheet3!A2].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.KEYS))
[Sheet3!A1].Resize(1, Y.Count) = Application.Transpose(Application.Transpose(Y.ITEMS))
With Sheets("Sheet3").UsedRange
   .Sort Key1:=.Item(2, 1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   Brr = .Resize(UBound(Arr))
End With
Y.RemoveAll
For i = 1 To UBound(Brr, 2)
   Y(Brr(1, i)) = i
Next
For i = 2 To UBound(Arr)
   For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
         Y(i & "|" & Arr(i, j)) = Arr(i, 1)
      End If
   Next
Next
For Each xR In Y.KEYS
   If InStr(xR, "|") Then
      T = Mid(xR, InStr(xR, "|") + 1)
      If Y(T & Y(xR)) = "" Then
         S = Y(T & "/a") + 1
         Brr(S + 1, Y(T)) = Y(xR)
         Y(T & "/a") = S
         Y(T & Y(xR)) = 1
      End If
   End If
Next
[Sheet3!A1].Resize(UBound(Brr), UBound(Brr, 2)) = Brr
Application.Goto [Sheet3!A1]
Set Arr = Nothing
Set Brr = Nothing
Set Y = Nothing
End Sub

Andy2483

¦^´_ 10# samwang


    'ÁÂÁ«e½ú«ü¾É!«á¾ÇÀò¯q¨}¦h
'1.«e½úªº±Æ°£­«½Æªº±¡¹Ò¬O»{¬° °ªOªâ ¬O±µ¨ü³ø¦Wªºµn¿ýªÌ­«½Æµn¿ý¸Ó©m¦W,
'«á¾Çªº±Æ°£­«½Æªº±¡¹Ò¬O»{¬° °ªOªâ ¬O¨â­Ó¤£¦P¦W(¥HO¼Ò½k¤Æ¤¤¶¡¦r)ªºµ²ªG,©Î¦P¦W¦P©m,
'¤@¥ó¨Æ¤£¦P¬Ýªk¥¿¬O«á¾Ç°õ©À·Q¸õ²æªº,§ó¯à²`«ä¼ô¼{,¹ï¿ù¤£¬O­«ÂI,¬O¦³½ìªº¾Ç²ß°Ê¤O
'2.«e½úªº±Æ°£­«½Æ§Þ¥©«á¾Ç¦¬¤U¤F,«Ý¦³¾÷·|À³¥Î³o§Þ¥©
'3.³oR = R + 2³o¬q«Ü¼F®`!«á¾Ç¾Ç¨ì¤F
'4.½Ð¦A¦h¦h«ü±Ð!ÁÂÁÂ
Option Explicit
Sub test_samwang()
Dim Arr, Brr, Crr, xD, xR, i&, j&, S&, N&, M&, R&, C&, D As Date
'¡ô«Å§iÅܼÆ:
'(Arr, Brr, Crr, xD, xR):³q¥Î«¬
'(i&, j&, S&, N&, M&, R&, C&):ªø¾ã¼Æ
'(D):¤é´Á
Set xD = CreateObject("Scripting.Dictionary")
'¡ô¥OxD ¬O¦r¨å
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
'¡ô¥O"Sheet1" ¤u§@ªí¦³¨Ï¥ÎªºÀx¦s®æÂX®i¬°³Ì¤p¤è¥¿½d³òÀx¦s®æ½Æ»s¨ì [Sheet3!A1]¶}©lªº½d³ò
With Sheets("Sheet3").UsedRange
'¡ô¥H¤U¬O ¦³Ãöªí¤T¦³¨Ï¥ÎªºÀx¦s®æÂX®i¬°³Ì¤p¤è¥¿½d³òÀx¦s®æªºµ{§Ç
    .Replace What:=" ", Replacement:="", LookAt:=xlPart
    '¡ô§â" "ªÅ¥Õ¦r¤¸¸m´«¬°""ªÅ¦r¤¸
    .Sort Key1:=.Item(1), Order1:=1, Header:=1, Orientation:=xlTopToBottom
    '¡ô.¾ã­Ó½d³ò±Æ§Ç:key°ò·Ç¬O¾ã­Ó½d³òªº¯Á¤Þ½s¸¹ 1ªºÀx¦s®æ©Ò¦bªºÄæ¦ì
    'Order1:=1±Æ§Ç¤è¦¡¬O ¥Ñ¤p¨ì¤j
    'Header:=1¦³¼ÐÃD¦C,¤£°Ñ»P±Æ§Ç
    'Áa¦V±Æ§Ç
   
    'Orientation:=xlTopToBottom³o Áa¦V±Æ§Çªº³¯­z³Ì¦n¥[¤W!
    '¤£µMEXCEL¦n¹³·|Àx¦s³Ì«á¤@¦¸ªº±Æ§Ç¤è¦¡:
    '¨Ò¦p «e¦¸¦pªG°µOrientation:=xlLeftToRight,¦¹¦¸¥H¬°ªºÁa¦V±Æ§Ç¬O°µ¾î¦V±Æ§Ç
    '¾Ç²ß³o©«±o¨ìªº¥H¬°EXCELÃa±¼ªº¥i¯º¸gÅç
    Arr = .Value
    '¡ô¥OArr¬O ¤Gºû°}¦C!¶K¤J±Æ§Ç«áªº¾ã­Ó½d³òÀx¦s®æ­È
    Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
    '¡ô¥OBrr¬O ¤Gºû°}¦C!¶K¤J±Æ§Ç«áªº¾ã­Ó½d³òªº¤£§t¼ÐÃD¦C¤]¤£§t¼ÐÃDÄæ(©m¦WÄæ)Àx¦s®æ ­È
    .Clear
    '¥O ªí¤T²[»\¦³¨Ï¥ÎªºÀx¦s®æ³Ì¤p¤è¥¿°Ï°ìÀx¦s®æ²M°£
End With
ReDim Crr(1 To UBound(Arr), 1 To 2)
'«Å§iCrr¤Gºû°}¦Cªº½d³ò!Áa¦V±q1¨ì Arr°}¦CÁa¦V³Ì¤j¦C¸¹¼Æ ¦C,¾î¦V±q1¨ì2Äæ
For Each xR In Brr
'¡ô³]¶¶°j°é!¥OxR¬OBrrªº¤@­Ó°}¦C­È±q¥ª¨ì¥k/¤U¨ì¤W ¶]
    If InStr(xR, "±è") Then
    '¡ô¦pªGxRªº¦r¦ê­È¸Ì¦³¥]§t"±è"¦r¤¸??
        S = InStr(xR, "±è") + 1
        '¡ô¥OS¼Æ¦rÅܼƬO "±è"¦r¤¸¦bxR¦r¦ê¸Ì¦r¤¸¦ì¸m¼Æ+1
        N = InStr(xR, "(")
        '¡ô¥ON¼Æ¦rÅܼƬO "("¦r¤¸¦bxR¦r¦ê¸Ì¦r¤¸¦ì¸m¼Æ
        D = Mid(xR, S, N - S)
        '¡ô¥OD¬O xR¦r¦ê¸Ì±qS¦ì¸m¶}©l,¨úN - S­Ó¦r¤¸ªº¦r¦ê«á,Âà¤Æ¬°¤é´Á,
        '­ì¨ÓÂ^¨úªº¦r¦ê¬O¨S¦³¦~¤Àªº¤é´Á¦r¦ê,EXCEL·|¦Û°Ê¥[¤W¤µ¦~ªº¦~¥÷,
        '¦pªG¤é´Á¬O¸ó¦~¤À,±Æ§Ç´N¥i¯à¥X°ÝÃD¤F,¨Ï¥ÎªÌ­nª`·N!!
        '¥i¥H§ï¥Î§¹¾ãªº¦~/¤ë/¤éµn¿ý°µ§ïµ½
        If Not xD.Exists(D) Then
        '¡ô¦pªG¥HD¤é´ÁÅܼƬd¹îxD¦r¨åµ²ªG¬O¤£¦s¦b³okey??
            i = i + 1
            '¡ô¥Oi¼Æ¦rÅܼƲ֥[1
            xD(D) = i
            '¡ô¥O¥HD¤é´ÁÅܼƬ°key,item¬O iÅܼÆ,©ñ¤JxD¦r¨å¸Ì
            Crr(i, 1) = D
            '¡ô¥Oi°j°é¦C²Ä1ÄæCrr°}¦C­È¬O D¤é´ÁÅܼÆ
            Crr(i, 2) = Trim(xR)
            '¡ô¥Oi°j°é¦C²Ä1ÄæCrr°}¦C­È¬O xR¦r¦ê¥h°£ÀY§ÀªÅ¥Õ¦r¤¸
            '³oTrim()À³¸Ó¥i¥H¬Ù²¤,³Q«á¾Ç»~¾É¤F
        End If
    End If
Next
With Sheets("Sheet3").[a1].Resize(i, 2)
'¡ô¥H¤U¬OÃö©óªí¤T[A1]Àx¦s®æ¶}©lÂX®i¦V¤Ui¦C,¦V¥kÂX®i2Ä檺Àx¦s®æ¶°
    .Value = Crr
    '¡ô¥OCrr°}¦C­È­Ë¤JÀx¦s®æ¶°¸Ì
    .Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
    '¡ô.¾ã­Ó½d³ò±Æ§Ç:key°ò·Ç¬O¾ã­Ó½d³òªº¯Á¤Þ½s¸¹ 1ªºÀx¦s®æ©Ò¦bªºÄæ¦ì
    'Order1:=1±Æ§Ç¤è¦¡¬O ¥Ñ¤p¨ì¤j
    'Header:=2 ¨S¦³¼ÐÃD¦C
    'Áa¦V±Æ§Ç
    Brr = .Value
    '¥O­ìBrr¤Gºû°}¦Cªì©l¤Æ«á,­«·s¸Ë¤J±Æ§Ç«áªºÀx¦s®æ¶° ­È
    .Clear
    '¥O ªí¤TÀx¦s®æ¶° ²M°£
End With
xD.RemoveAll
'¡ô²MªÅxD¦r¨å
ReDim Crr(1 To UBound(Arr), 1 To i)
'¡ô¥O­ìCrr¤Gºû°}¦Cªì©l¤Æ«á,«Å§iCrr¤Gºû°}¦Cªº½d³ò!Áa¦V±q1¨ìArr°}¦CÁa¦V³Ì¤j¦C¸¹¼Æ¦C,
'¾î¦V±q1¨ìiÅܼÆÄæ
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°é!ÅܼÆi±q1¨ìBrr°}¦CÁa¦V³Ì¤j¦C¸¹¼Æ
   M = M + 1
   '¡ôM¼Æ¦rÅܼƲ֥[ 1
   xD(Brr(i, 2)) = M    '@@1
   '¡ô¥O¥Hi°j°é¦C²Ä2Ä檺Brr°}¦C­È·íkey,item¬O M¼Æ¦rÅܼÆ!­Ë¤JxD¦r¨å¸Ì
   Crr(1, M) = Brr(i, 2)
   '¡ô¥O²Ä1¦CM¼Æ¦rÅܼÆÄæCrr°}¦C­È¬O i°j°é¦C²Ä2Ä檺Brr°}¦C­È PS:³B¸Ìµ²ªGªí¼ÐÃD¦C
Next
For i = 2 To UBound(Arr)
'¡ô³]¥~¶¶°j°é!iÅܼƱq2¨ì Arr°}¦CÁa¦V³Ì¤j¦C¸¹¼Æ
   For j = 2 To UBound(Arr, 2)
   '¡ô³]¥~¶¶°j°é!jÅܼƱq2¨ì Arr°}¦C¾î¦V³Ì¤jÄ渹¼Æ
      If Arr(i, j) <> "" Then
      '¡ô¦pªGi°j°é¦Cj°j°éÄ檺Arr°}¦C­È ¤£¬OªÅªº
        If Not xD.Exists(Arr(i, j) & "|" & Arr(i, 1)) Then
        '¡ô¦A¦pªG ¥H±è¦¸¤é´Á¬P´Á¦r¦ê³s±µ"|"²Å¸¹,¦A³s±µ ©m¦Wªº²Õ¦X¦r¦ê,
        '¬d¹îxD¦r¨åµ²ªG¬O¤£¦s¦b³okey ??
            R = xD(Arr(i, j) & "|R")
            '¡ô¥OR¼Æ¦rÅܼƬO ¥H±è¦¸¤é´Á¬P´Á¦r¦ê³s±µ"|R"¦r¦êªº·s¦r¦ê,
            '¬d¹îxD¦r¨å±o¨ìªºitem­È
            If R = 0 Then
            '¡ô¦pªGR³o¼Æ¦rÅܼƬO 0 ??
               R = R + 2
               '¡ôIf±ø¥ó¦¨¥ß!´N¥OR¼Æ¦rÅܼƲ֥[ 2  (©ñµ²ªGªº¦C¸¹)
               '¦]¬°¨CÄæ©m¦W¬O±q²Ä2¦C¶}©lÂ\©ñ!©Ò¥H¥[ 2
               Else
                  R = R + 1
                  '¡ôIf±ø¥ó¤£¦¨¥ß!´N¥OR¼Æ¦rÅܼƲ֥[ 1  (©ñµ²ªGªº¦C¸¹)
            End If
            C = xD(Arr(i, j) & "")
            '¡ô¥OC¼Æ¦rÅܼƬO ±è¦¸¤é´Á¬P´Á¦r¦ê³s±µ""ªº·s¦r¦ê,
            '¬d¹îxD¦r¨å±o¨ìªºitem­È (©ñµ²ªGªºÄ渹,¦p¤W¤è @@1¼Ðµù¦ì¸m)
            Crr(R, C) = Arr(i, 1)
            '¡ô¥ORÅܼƦCCÅܼÆÄ檺Crr°}¦C­È¬O i°j°éªº©m¦W
            xD(Arr(i, j) & "|R") = R
            '¡ô¥O¥H±è¦¸¤é´Á¬P´Á¦r¦ê³s±µ"|R"¦r¦êªº¦r¦ê¬°key,item¬O ©ñµ²ªGªº¦C¸¹,
            '©ñ¤JxD¦r¨å¸Ì©Î¸m´«¸Ókey¹ïÀ³ªºitem­È
            xD(Arr(i, j) & "|" & Arr(i, 1)) = ""
            '¡ô¥O¥H±è¦¸¤é´Á¬P´Á¦r¦ê³s±µ"|"²Å¸¹,¦A³s±µ ©m¦Wªº²Õ¦X¦r¦ê¬°key,
            'item¬OªÅ¦r¤¸,©ñ¤JxD¦r¨å¸Ì  ±Æ°£­«½Æ³ø¦W
         End If
      End If
   Next j
Next i
[Sheet3!A1].Resize(UBound(Crr), M) = Crr
'¡ô¥Oªí¤T[A1]ÂX®i¦V¤U Crr°}¦CÁa¦V³Ì¤j¦C¸¹¼Æ¦C,¦V¥kÂX®iMÄ檺Àx¦s®æ,­Ë¤JCrr°}¦C­È
Application.Goto [Sheet3!A1]
End Sub

samwang

¦^´_ 1# Andy2483

±z¼g±o«Ü¦n¤F¡A°Ñ¦Ò±zªº­×§ï¤@¤U¡AÁÂÁÂ

Sub test()
Dim Arr, Brr, Crr, xD, xR, i&, j&, S&, N&, M&, R&, C&, D As Date
Set xD = CreateObject("Scripting.Dictionary")
Sheets("Sheet1").UsedRange.Copy [Sheet3!A1]
With Sheets("Sheet3").UsedRange
    .Replace What:=" ", Replacement:="", LookAt:=xlPart
    .Sort Key1:=.Item(1), Order1:=1, Header:=1
    Arr = .Value
    Brr = Range(.Cells(2, 2), .Cells(UBound(Arr), UBound(Arr, 2))).Value
    .Clear
End With
ReDim Crr(1 To UBound(Arr), 1 To 2)
For Each xR In Brr
    If InStr(xR, "±è") Then
        S = InStr(xR, "±è") + 1
        N = InStr(xR, "(")
        D = Mid(xR, S, N - S)
        If Not xD.Exists(D) Then
            i = i + 1: xD(D) = i
            Crr(i, 1) = D: Crr(i, 2) = Trim(xR)
        End If
    End If
Next
With Sheets("Sheet3").[a1].Resize(i, 2)
        .Value = Crr
        .Sort Key1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
        Brr = .Value
        .Clear
End With
xD.RemoveAll
ReDim Crr(1 To UBound(Arr), 1 To i)
For i = 1 To UBound(Brr)
   M = M + 1: xD(Brr(i, 2)) = M
   Crr(1, M) = Brr(i, 2)
Next
For i = 2 To UBound(Arr)
   For j = 2 To UBound(Arr, 2)
      If Arr(i, j) <> "" Then
        If Not xD.Exists(Arr(i, j) & "|" & Arr(i, 1)) Then
            R = xD(Arr(i, j) & "|R")
            If R = 0 Then R = R + 2 Else R = R + 1
            C = xD(Arr(i, j) & "")
            Crr(R, C) = Arr(i, 1)
            xD(Arr(i, j) & "|R") = R
            xD(Arr(i, j) & "|" & Arr(i, 1)) = ""
         End If
      End If
   Next j
Next i
[Sheet3!A1].Resize(UBound(Crr), M) = Crr
Application.Goto [Sheet3!A1]
End Sub

Andy2483

¦^´_  Andy2483


·Pı¦n¹³¦³¤@©Û
·Ç¤jÁÙ¦³¨ä¥L¤j¤j±`¥Îªº°µªk
¦r¨å´O®M ©Î ¦r¨å¦X¨Ökey­È(¦C¸¹+ÃöÁä ...
singo1232001 µoªí©ó 2022-12-7 22:36

    ÁÂÁ«e½ú«üÂI
«á¾Ç(«pÁy¥Öªº¾Ç¥Í)¨Ó¬ã¨s¤@¤U!
¥i¬O«e½ú»¡ªº¤è¦¡«ÜÅ]ªk,¥i¥H¦A¦h´£¥Ü¤@ÂI¶Ü?
Àµ½Ð«e½ú¨q¤W±zªº¤è®×¶Ü?
­þ¤@©«¦³³oºØÅ]ªk©Û¦¡?½Ð«e½ú¦A´£ÂI¤@¤U!
«ô°U!

singo1232001

¦^´_ 7# Andy2483


·Pı¦n¹³¦³¤@©Û
·Ç¤jÁÙ¦³¨ä¥L¤j¤j±`¥Îªº°µªk
¦r¨å´O®M ©Î ¦r¨å¦X¨Ökey­È(¦C¸¹+ÃöÁä¦r)
¥i¥HÁYµuµ{§Ç
­Y­n¨ú¥X¦C¸¹ ¦A¥Îreplace§âÃöÁä¦r²¾±¼

Andy2483

ÁÂÁ½׾Â
¤µ¤Ñ¦Û¤vµù¸Ñµ{¦¡½X½èºÃ¤F¦Û¤v¬O§_¯uÀ´¨C­Ó³¯­z.²[¦¡...,ÁÙ¬O¥u·|§Ûŧ
item() :·|¨Ì¦ì¸m©Î«öÁä¶Ç¦^ ¶°¦X ª«¥óªº¯S©w ¦¨­û¡C
https://learn.microsoft.com/zh-tw/office/vba/language/reference/user-interface-help/item-method-visual-basic-for-applications
¥H¤U¬O#6¼Óªº¤ß±oµù¸Ñ

Option Explicit
Sub TEST_±Æ°£¸ê®Æªí­«½Æ¦C_ª½¦¡±è¦¸¦W³æ_¥ý¾ã²z¦A±Æ§Ç()
Dim Brr, Crr, xR, Z, xA, V, W, P, Sh1, SH3
'¡ô«Å§i³q¥Î«¬ÅܼÆ
Dim i&, j&, S&, N&, R&, C&, X&, Y&, Q&
'¡ô«Å§iªø¾ã¼ÆÅܼÆ
Dim D As Date, Da$, T$
'¡ô«Å§iÅܼÆ!(D)¬O¤é´ÁÅܼÆ,(Da,T)¬O¦r¦êÅܼÆ
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
'¡ô¥OW,Z,P¦U¬O¦r¨å
Set Sh1 = Sheets("Sheet1")
'¡ô¥OSh1¬O "Sheet1" ¤u§@ªí
Set SH3 = Sheets("Sheet3")
'¡ô¥OSh1¬O "Sheet3" ¤u§@ªí
SH3.UsedRange.Clear
'¡ô¥O "Sheet3" ¤u§@ªí²[»\¦³¨Ï¥ÎªºÀx¦s®æ³Ì¤p¤è¥¿°Ï°ì²M°£
Crr = Range(Sh1.[A1], Sh1.UsedRange).Offset(1, 0)
'¡ô¥OCrr¬O ªí1[A1]¨ì¦³¨Ï¥ÎÀx¦s®æªº³Ì¤p¤è¥¿½d³òÀx¦s®æ©¹¤U°¾²¾1¦C½d³òªº­È
R = UBound(Crr) - 1
'¡ô¥OR¬O Crr°}¦CÁa¦V³Ì¤j¦C¸¹¼Æ´î 1
C = UBound(Crr, 2)
'¡ô¥OC¬O Crr°}¦C¾î¦V³Ì¤j¦C¸¹¼Æ
ReDim Brr(1 To R, 1 To C)
'¡ô«Å§iBrr°}¦C½d³ò!Áa¦V±q1¨ìR,¾î¦V±q1¨ìC
ReDim V(R - 1)
'¡ô«Å§iV¬O¤@ºû°}¦C!¯Á¤Þ½d³ò±q0¨ìR - 1
For i = 1 To R
'¡ô³]¥~¶¶°j°é!i±q1¨ìR
   Da = ""
   '¡ô¥ODa¦r¦êÅܼƬOªÅ¦r¤¸
   For j = 1 To C
   '¡ô³]¤º¶¶°j°é!j±q1¨ìC
      Da = Da & "/" & Crr(i, j)
      '¡ô¥ODa¦r¦êÅܼƬO ¦Û¤v³s±µ"/"²Å¸¹,¦A³s±µi°j°é¦Cj°j°éÄ檺Crr°}¦C­È
   Next
   If W.Exists(Da) = Empty Then
   '¡ô¦pªG¥HDa·íkey¬d¹îW¦r¨å¸Ì¬Oªì©l­È
      Q = Q + 1
      '¡ô¥OQÅܼƲ֥[1
      For j = 1 To C
      '¡ô³]¤º¶¶°j°é!j±q1¨ìC
         Brr(Q, j) = Trim(Crr(i, j))
         '¡ô¥OQÅܼƦC²Äj°j°éÄ檺Brr°}¦C­È¬O i°j°é¦C²Ä°j°éjÄ檺­È¥h±¼ÀY§ÀªºªÅ¥Õ¦r¤¸
      Next
      W(Da) = ""
      '¡ô¥O¥HDa¦r¦êÅܼƭȷíkey,item¬OªÅ¦r¤¸­Ë¤JW¦r¨å¸Ì
   End If
Next
W.RemoveAll
'¡ô²MªÅW¦r¨å
For Each xR In Brr
'¡ô³]¶¶°j°é!¥OxR ¬OBrr°}¦Cªº¤@­û
   If InStr(xR, "(") Then
   '¡ô¦pªGxR­È¸Ì¦³¥]§t"("²Å¸¹?
      S = InStr(xR, "±è") + 1
      '¡ô¥OS¬OxR§PÂ_ "±è"¦r¤¸©Ò¦b¦r¤¸¦ì¸m¼Æ
      N = InStr(xR, "(")
      '¡ô¥ON ¬O xR§PÂ_ "("¦r¤¸©Ò¦b¦r¤¸¦ì¸m¼Æ
      D = Mid(xR, S, N - S)
      '¡ô¥OD¬O xR­È±qS¦r¤¸¶}©l¨ú N - S­Ó¦rªº¦r¦ê¦AÅܬ°¤é´Á
      W(D) = xR
      '¡ô¥OD³o¤é´Á·íkey,item¬OxRªº­È
      P(xR) = D
      '¡ô¥OxR³o¤é´Á·íkey,item¬ODªº­È
   End If
Next
For Each xA In W.KEYS
'¡ô³]¶¶°j°é!¥OxA ¬OW¦r¨å¸Ìkeysªº¤@­û
   Z(xA) = V
   '¡ô¥O¥HxA¬°key,item¬OV¤@ºû°}¦C,­Ë¤JZ¦r¨å¸Ì
Next
For i = 1 To Q
'¡ô³]¥~¶¶°j°é!i±q1¨ìQ
   For j = 2 To C
   '¡ô³]¤º¶¶°j°é!j±q1¨ìQ
      T = Brr(i, j)
      '¡ô¥OT¦r¦êÅܼƬOi°j°é¦Cj°j°éÄ檺Brr°}¦C­È
      If T <> "" Then
      '¡ô¦pªGT¦r¦êÅܼƤ£µ¥©óªÅ¦r¤¸??
         V = Z(P(T))
         '¡ô¥OV³o³q¥Î«¬ÅܼƬO ¥HT¦r¦ê¬d¹îP¦r¨åªºitem­È¦A¬d¹îZ¦r¨å±o¨ìªºitem(¤@ºû°}¦C)
         X = W(T & "|") + 1
         '¡ô¥OX³o¼Æ¦rÅܼƬO ¥HT¦r¦ê³s±µ"|"²Å¸¹¬d¹î¦r¨åªºitem­È²Ö¥[ 1
         V(X - 1) = Brr(i, 1)
         '¡ô¥OV³o¤@ºû°}¦Cªº¯Á¤Þ¸¹¬O X-1ªº¤¸¯À¬O ¬Oi°j°é¦C²Ä¤@Ä檺Brr°}¦C­È
         W(T & "|") = X
         '¡ô¥O¥HT¦r¦ê³s±µ"|"²Å¸¹¬°keyªºitem¬O ¼Æ¦rÅܼÆX
         Z(P(T)) = V
         '¡ô¥O¥HT¦r¦ê¬d¹îP¦r¨åªºitem­È¦A¬d¹îZ¦r¨å±o¨ìªºitem¬O ¤@ºû°}¦CV
      End If
   Next j
Next i
SH3.[A1].Resize(1, Z.Count) = Application.Transpose(Application.Transpose(Z.KEYS))
'¡ô¥Oªí¤T[A1]ÂX®i¦V¤UÂX®i1¦C(A1¦Û¨­¦C),¦V¥kÂX®iZ¦r¨åÁä¼ÆÄæ¬O Z¦r¨åkeyÂà¸m¨â¦¸ªº­È
SH3.[A2].Resize(Q, Z.Count) = Application.Transpose(Z.ITEMS)
'¡ô¥Oªí¤T[A2]ÂX®i¦V¤UÂX®i Q¦C,¦V¥kÂX®iZ¦r¨åÁä¼ÆÄæ¬O Z¦r¨åkeyÂà¸m¨â¦¸ªº­È
For i = 1 To SH3.UsedRange.Columns.Count
'¡ô³]¶¶°j°é!i±q1¨ì ªí¤T¨Ï¥Î½d³òªºÄæ¼Æ
   With Range(SH3.Cells(1, i), SH3.Cells(Rows.Count, i).End(3))
   '¡ô¥H¤U¬O¦³Ãö©óªí¤T ¨C¤@Ä榳¤º®eªºÀx¦s®æµ{§Ç
      .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
      '¡ô±Æ§Ç:°ò·Ç¬O½d³ò¸Ì²Ä¤@®æÄæ¦ì,¤j¨ì¤p,¨S¦³¼ÐÃD¦C,Áa¦V±Æ§Ç±q¤W¨ì¤U
   End With
Next
With SH3.UsedRange
'¡ô¥H¤U¬O¦³Ãö©óªí¤T¨Ï¥Î½d³òªºÀx¦s®æµ{§Ç
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   '¡ô±Æ§Ç:°ò·Ç¬O½d³ò¸Ì²Ä¤@®æ¦C¦ì,¤j¨ì¤p,¨S¦³¼ÐÃD¦C,Áa¦V±Æ§Ç±q¥ª¨ì¥k
   For i = 1 To .Columns.Count
   '¡ô³]¶¶°j°é!i±q1 ¨ìªí¤T¨Ï¥Î½d³òªºÄæ¼Æ
      D = .Cells(1, i)
      '¡ô¥OD¤é´ÁÅܼƬO ªí¤T¨Ï¥Î½d³òªº¬Û¹ïÀx¦s®æ²Ä1¦C²Äi°j°éÅܼÆÄ檺­ÈÂন¤é´Á
      .Cells(1, i) = W(D)
      '¡ô¥O¥H ªí¤T¨Ï¥Î½d³òªº¬Û¹ïÀx¦s®æ²Ä1¦C²Äi°j°éÅܼÆÄ檺­È¬d¹îW¦r¨å±o¨ìªºitem­È(¦r¦ê)
      'ªº­È©ñ¤J·í®æ
   Next
End With
Application.Goto [Sheet3!A1]
Set Crr = Nothing
Set Brr = Nothing
Set W = Nothing
Set Z = Nothing
Set P = Nothing
End Sub

Sub Itemªº³W«h()
Dim Area As Range
Set Area = [A1:J10]
MsgBox Area.Item(1).Address
MsgBox Area.Item(5).Address
MsgBox Area.Item(10).Address
MsgBox Area.Item(11).Address
MsgBox Area.Item(100).Address
MsgBox Area.Item(101).Address
'¡ô½d³ò¤º¥Ñ¥ª¨ì¥k,¤W¨ì¤U¼ÐÀx¦s®æ¯Á¤Þ
MsgBox Area.Item(1, 1).Address
MsgBox Area.Item(1, 5).Address
MsgBox Area.Item(1, 10).Address
MsgBox Area.Item(2, 1).Address
MsgBox Area.Item(10, 10).Address
MsgBox Area.Item(1, 11).Address
'¡ô½d³ò¤ºªº®y¼Ð¤è¦¡¼ÐÀx¦s®æ¯Á¤Þ
End Sub

Andy2483

¤µ¤Ñ½m²ß¦h­Ó¦r¨å»P°}¦C,±Æ°£¸ê®Æªí­«½Æ¦C_¾ã²z¦¨ª½¦¡±è¦¸¦W³æ_¤è¦¡:¥ý¾ã²z¦A±Æ§Ç
¥H¤U¬Oµ²ªG,½Ð¦U¦ì«e½ú«ü¾É!ÁÂÁÂ
ÁܽФj®a¤@°_¤W½×¾Â¾Ç²ß!°Q½×!
°õ¦æµ²ªG:

¤U¸ü (298.35 KB)

2022-12-6 16:51

PS:¦³¨â­Ó °ªOªâ ¤£¦P±è¦¸
Option Explicit
Sub TEST_±Æ°£¸ê®Æªí­«½Æ¦C_ª½¦¡±è¦¸¦W³æ_¥ý¾ã²z¦A±Æ§Ç()
Dim Brr, Crr, xR, Z, xA, V, W, P, Sh1, SH3
Dim i&, j&, S&, N&, R&, C&, X&, Y&, Q&
Dim D As Date, Da$, T$
Set W = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set P = CreateObject("Scripting.Dictionary")
Set Sh1 = Sheets("Sheet1")
Set SH3 = Sheets("Sheet3")
SH3.UsedRange.Clear
Crr = Range(Sh1.[A1], Sh1.UsedRange).Offset(1, 0)
R = UBound(Crr) - 1
C = UBound(Crr, 2)
ReDim Brr(1 To R, 1 To C)
ReDim V(R - 1)
For i = 1 To R
   Da = ""
   For j = 1 To C
      Da = Da & "/" & Crr(i, j)
   Next
   If W.Exists(Da) = Empty Then
      Q = Q + 1
      For j = 1 To C
         Brr(Q, j) = Trim(Crr(i, j))
      Next
      W(Da) = ""
   End If
Next
W.RemoveAll
For Each xR In Brr
   If InStr(xR, "(") Then
      S = InStr(xR, "±è") + 1
      N = InStr(xR, "(")
      D = Mid(xR, S, N - S)
      W(D) = xR
      P(xR) = D
   End If
Next
For Each xA In W.KEYS
   Z(xA) = V
Next
For i = 1 To Q
   For j = 2 To C
      T = Brr(i, j)
      If T <> "" Then
         V = Z(P(T))
         X = W(T & "|") + 1
         V(X - 1) = Brr(i, 1)
         W(T & "|") = X
         Z(P(T)) = V
      End If
   Next j
Next i
SH3.[A1].Resize(1, Z.Count) = Application.Transpose(Application.Transpose(Z.KEYS))
SH3.[A2].Resize(Q, Z.Count) = Application.Transpose(Z.ITEMS)
For i = 1 To SH3.UsedRange.Columns.Count
   With Range(SH3.Cells(1, i), SH3.Cells(Rows.Count, i).End(3))
      .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlTopToBottom
   End With
Next
With SH3.UsedRange
   .Sort KEY1:=.Item(1), Order1:=1, Header:=2, Orientation:=xlLeftToRight
   For i = 1 To .Columns.Count
      D = .Cells(1, i)
      .Cells(1, i) = W(D)
   Next
End With
Application.Goto [Sheet3!A1]
Set Crr = Nothing
Set Brr = Nothing
Set W = Nothing
Set Z = Nothing
Set P = Nothing
End Sub

hcm19522

¦^´_ 4# Andy2483

¾Ç²ßºë¯«¥i¹Å «ö­ÓÆg

OFFSET(Àx¦s®æ¦WºÙ,¤W¤U²¾°Ê¼Æ,¥ª¥k²¾°Ê¼Æ,¤W¤U°Ï¶¡¼Æ,¥ª¥k°Ï¶¡¼Æ)  ¾ãÄæ©Î¾ã¦C «á¤G°Ñ¼Æ¥i¬Ù±¼

  «á­± &""-->Àx¦s®æ­Y¬°ªÅ «hªÅ §_«h¬° 0

https://blog.xuite.net/hcm19522/twblog/590645095