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

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

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

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-12-2 15:38 ½s¿è

¦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¹Ï
2022-12-02_144904.JPG
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¦^´_

êɤF!¨S³B²z­«½Æªº¦W³æ!
½Ð¦U¦ì«e½ú«ü¾É!ÁÂÁÂ

TOP

ÀH·NºÛ "EXCEL°g"  blog  ©Îhttps://hcm19522.blogspot.com/ EXCEL¨ç¼Æ

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-12-5 11:22 ½s¿è

¦^´_ 3# hcm19522


    ÁÂÁ«e½ú«ü¾É OFFSET() ªº¥Îªk
2022-12-05_110640.JPG
2022-12-5 11:09


«á¾Ç¾Ç²ß¤ß±o¦p¤U,½Ð«e½ú¦A«ü¾É!ÁÂÁÂ
H1=OFFSET($A$1,COLUMN(A1),ROW(A1)-1)&""
¥O[H1]Àx¦s®æªº­È¬O:©T©w¼ÐªºÀx¦s®æ[A1] °¾²¾¦ì¸m®æªº­È, ¦A³s±µªÅ¦r¤¸ ªº­È(¥H§K¼ÐªÅ¥Õªº¥Ø¼Ð®æ,Åýµ²ªG®æ­ÈÅã¥Ü 0)

1.$A$1¬O¤@­Ó©T©w¦ì§}ªºÀx¦s®æ; $A¬O©T©wÄæ¦ìªº·N«ä; $1¬O¦C¦ì©T©wªº·N«ä
1.1.¨ä¥L¦p $A1:¬OÄæ¦ì©T©w,¦C¦ì¤£©T©wªº·N«ä
1.2.¨ä¥L¦p A$1:¬OÄæ¦ì¤£©T©w,¦C¦ì©T©wªº·N«ä
1.3.¨ä¥L¦p A1:¬OÄæ¦ì¤£©T©w,¦C¦ì¤]¤£©T©wªº·N«ä

2..°¾²¾¦ì¸m®æªº­È
2.1.[A1]Àx¦s®æ°¾²¾©¹¤U°¾²¾  COLUMN(A1) ¦C¼Æ:[A1]¦Û¨­ªºÄæ¦ì´N¬O 1
2.2.[A1]Àx¦s®æ°¾²¾©¹¾î¦V°¾²¾ ROW(A1)-1 Äæ¦ì:[A1]¦Û¨­ªº¦C¦ì¬O 1,´î±¼1Åܦ¨ 0(¤£°¾²¾ªº·N«ä)
https://support.microsoft.com/zh-tw/office/offset-%E5%87%BD%E6%95%B8-c8de19ae-dd79-4b9b-a14e-b4d906d11b66
=OFFSET($A$1,0,0)  µ²ªG>>        ²Ä1±è
=OFFSET($A$1,1,0)  µ²ªG>>        A1

3.§â¦C¦ì»PÄæ¦ì°Ñ¼Æ¤Æ!ÅýÄæ¼Æ»P¦C¼Æ¹ï½Õ,§e²{¥X·Q­nªº­È,¦A[H1]½Æ»s¨ì[H1:T5]³o¨Çµ²ªG®æ,´N·|²£¥ÍÂà¸mªº®ÄªG

TOP

¥»©«³Ì«á¥Ñ hcm19522 ©ó 2022-12-5 13:42 ½s¿è

¦^´_ 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
ÀH·NºÛ "EXCEL°g"  blog  ©Îhttps://hcm19522.blogspot.com/ EXCEL¨ç¼Æ

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-12-6 16:54 ½s¿è

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

TOP

ÁÂÁ½׾Â
¤µ¤Ñ¦Û¤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

TOP

¦^´_ 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²¾±¼

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2022-12-8 07:28 ½s¿è
¦^´_  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!

TOP

¦^´_ 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

TOP

        ÀR«ä¦Û¦b : «H¤ß¡B¼Ý¤O¡B«i®ð¤TªÌ¨ã³Æ¡A«h¤Ñ¤U¨S¦³°µ¤£¦¨ªº¨Æ¡C
ªð¦^¦Cªí ¤W¤@¥DÃD