ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

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

¦^´_ 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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 8# singo1232001


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


µ²ªG:
2022-12-19_144406.JPG
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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : Ä@­n¤j¡B§Ó­n°í¡B®ð­n¬X¡B¤ß­n²Ó¡C
ªð¦^¦Cªí ¤W¤@¥DÃD