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

[µo°Ý] ­«·s±Æ§Ç

[µo°Ý] ­«·s±Æ§Ç

½Ð°Ý½×¾Âªº¤j¤j­Ì
¥H¤U¬Oªø©xªº»Ý¨D

¤U­±¬O±q¤½¥q¥´¥d¨t²Î¼´¥X¨ÓªºexcelÀÉ


ªø©x§Æ±æ¥i¥H°µ¦¨©³¤Uªº±Æ§Ç
²Ä¤@­Ó±Æ§Ç§ÚµLªk¨Ï¥Î¼Ï¯Ã§¹¦¨¡A½Ð°Ý¬O§_¥i¥H¥ÎVBA¨Ó§¹¦¨??


²Ä¤G­Ó±Æ§Ç¥i¥H¥Î¼Ï¯Ã§¹¦¨
¥u¬O§Ú°O±o¦b½×¾Â¤W¦n¹³¦³¬Ý¹L¦³¤H±Ð¾É¨Ï¥ÎVBA¥h§¹¦¨(Á{®É­n¥Î«o¤S§ä¤£¨ì)


2023°ê°².zip (214.81 KB)

¦C.PNG (17.3 KB)

¦C.PNG

¦^´_ 1# cowww


    ÁÂÁ½׾Â,ÁÂÁ«e½úµoªí¦¹¥DÃD»P½d¨Ò
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð«e½ú°Ñ¦Ò

°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 1000, 1 To 2), A, Y, R&, i&, TT$, T1$, T3$, T4 As Date, T9$
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9)
   TT = T1 & "|" & T3: A = Y(TT)
   If Not IsArray(A) Then A = Crr: Y(TT & "/½s") = T1: Y(TT & "/¦W") = T3
   R = Y(TT & "/R"): R = R + 1: Y(TT & "/R") = R:
   A(R, 1) = T4: A(R, 2) = T9: Y(TT) = A
Next
With Sheets("¤u§@ªí1")
   .UsedRange.Offset(1, 0).Clear: R = 1
   .Columns(1).NumberFormatLocal = "@"
   For Each A In Y.KEYS
      If Not IsArray(Y(A)) Then GoTo i01
      R = R + 1
      .Cells(R, 1) = Y(A & "/½s"): .Cells(R, 2) = Y(A & "/¦W")
      .Cells(R, 3).Resize(Y(A & "/R"), 2) = Y(A): R = R + Y(A & "/R") - 1
i01: Next
End With
Set Y = Nothing: Erase Brr, Crr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 2# Andy2483


«D±`·PÁÂAndy2483¤j¤jªº¸Ñ´b

½Ð°Ý¦³¿ìªk§ï¦¨³o¼Ë¶Ü??

TOP

¥»©«³Ì«á¥Ñ Andy2483 ©ó 2023-5-26 10:15 ½s¿è

¦^´_ 3# cowww


    ÁÂÁ«e½ú¦^´_
«e½úªººI¹Ï¸Ì¨C¦ì¾­û½Ð°²©ú²Ó¥u¦³°ê°²,¨ä¥¦°²§O¦p¦ó³B²z?
²£¥Xªº³øªí ¹ê»Ú¥Î³~¬O°µ¤°»ò¥Îªº?
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 4# Andy2483

¥Ø«e¥u­n°ê°²´N¦n
³o±iªí¥Ü­nµ¹OP¬Ý±o
OP¤H¼Æ«Ü¦h
¦pªG©ñ¦b¦P¤@Ä檺¸Ü¡A¦L¥X¨Óªº¯È±i´N·|«D±`ªºªø
©Ò¥Hªø©x¤~·|°Ý¯à¤£¯à°µ¦¨¤@¦C¤@¦Cªº¤è¦¡

¦pªG¥i¥Hªº¸Ü
§Ú§Æ±æ¥i¥H¥[­Ó¤U©Ô¦¡¿ï³æ¨Ó¿ï¾Ü¥ð°²ªº­ì¦]
¦]¬°§Úı±oªø©x¥i¯à·|´£¥XÃþ¦üªº°ÝÃD

TOP

¦^´_ 5# cowww


    ºî¦X¤è¦¡,½Ð«e½ú°Ñ¦Ò

°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Arr, Brr, Crr, V, A, Y, R&, i&, j%, TT$, T1$, T3$, T4 As Date, T9$, N&
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
With Sheets("¤u§@ªí1").[A1].Resize(UBound(Brr), UBound(Brr, 2))
   .Columns(1).NumberFormatLocal = "@"
   .Value = Brr
   .Sort KEY1:=.Item(1), Order1:=1, Key2:=.Item(4), Order2:=1, Header:=2
   Brr = .Value: .ClearContents
   For i = 1 To UBound(Brr): Y(Brr(i, 9)) = Y(Brr(i, 9)) + 1: Next: V = Y.keys()
   .Item(1).Resize(Y.Count, 1) = Application.Transpose(Y.items)
   .Item(2).Resize(Y.Count, 1) = Application.Transpose(Y.keys)
   .Sort KEY1:=.Item(1), Order1:=2, Key2:=.Item(2), Order2:=1, Header:=2
   Arr = .Item(1).CurrentRegion: .ClearContents
   Y.RemoveAll
End With
ReDim Crr(1 To UBound(Brr), 1 To UBound(Arr) + 3)
For i = 1 To UBound(Brr)
   If i = 1 Then
      Crr(1, 1) = "¤u¸¹": Crr(1, 2) = "©m¦W | Display Name": Crr(1, 3) = "¤Ñ¼Æ": N = 1
      For j = 1 To UBound(Arr): Crr(1, j + 3) = Arr(j, 2): Y(Arr(j, 2)) = j + 3: Next
   End If
   T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9): TT = T1 & "|" & T3
   If Y(TT) = "" Then N = N + 1: Y(TT) = N: Crr(N, 1) = T1: Crr(N, 2) = T3: R = Y(TT)
   Crr(R, Y(T9)) = Trim(Crr(R, Y(T9)) & " " & T4): Crr(N, 3) = Crr(N, 3) + 1
Next
With Sheets("¤u§@ªí1")
   .Columns(1).NumberFormatLocal = "@": .[A1].Resize(N, UBound(Crr, 2)) = Crr
End With
Set Y = Nothing: Erase Arr, Brr, Crr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 6# Andy2483

«D±`·PÁÂAndy2483¤j¤jªº¸Ñ´b


¬°¦óªø©x­n¨D­n°µ¦¨¸ò¤W­±¨º±iªí¤@¼Ë
¥D­n¬O¦]¬°²{³õªº§@·~­û¦h¥b³£¬O50·³¥H¤Wªº©n©n­Ì
²Ä¤@
¦o­Ìªºµø¤O¤£¬O«Ü¦n
²Ä¤G
¦o­Ì°£¤F·|·Æ·Æ¤â¾÷¬Ý¼v¤ù¥H¥~¡A´X¥G¨S¦³¸ê°T¯à¤O

©Ò¥HAndy2483¤j¤j§e²{¥X¨Óªº¼Ë¦¡
¦o­Ì¤@©w·|¥Í®ðªº

TOP

¦^´_ 7# cowww


    ¥Î«e¤@¤è®×µy§ï,¥ý°Ñ¦Ò

°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Arr, Brr, Crr, V, A, Y, R&, i&, j%, TT$, T1$, T3$, T4 As Date, T9$, N&
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
With Sheets("¤u§@ªí1").[A1].Resize(UBound(Brr), UBound(Brr, 2))
   .Columns(1).NumberFormatLocal = "@"
   .Value = Brr
   .Sort KEY1:=.Item(1), Order1:=1, Key2:=.Item(4), Order2:=1, Header:=2
   Brr = .Value: Sheets("¤u§@ªí1").UsedRange.ClearContents
End With
ReDim Crr(1 To UBound(Brr), 1 To 4)
For i = 1 To UBound(Brr)
   If i = 1 Then
      Crr(1, 1) = "¤u¸¹": Crr(1, 2) = "©m¦W | Display Name": Crr(1, 3) = "¤Ñ¼Æ": N = 1
   End If
   T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9): TT = T1 & "|" & T3
   If T9 <> "°ê°²" Then GoTo i01
   If Y(TT) = "" Then N = N + 1: Y(TT) = N: Crr(N, 1) = T1: Crr(N, 2) = T3: R = Y(TT)
   Crr(R, 4) = Crr(R, 4) & "¢i" & T4: Crr(N, 3) = Crr(N, 3) + 1
i01: Next
With Sheets("¤u§@ªí1")
   .Columns(1).NumberFormatLocal = "@": .[A1].Resize(N, 4) = Crr
End With
Set Y = Nothing: Erase Brr, Crr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 7# cowww


    ÁÂÁ«e½ú
«á¾ÇÂdzo¥DÃD½m²ß¦hºØ¤è®×,¥H¤U¬O¾Ç²ß¤è®×,½Ð«e½ú°Ñ¦Ò

°õ¦æµ²ªG:



Option Explicit
Sub TEST()
Application.ScreenUpdating = False
Dim Arr, Brr, Crr, V, A, Y, R&, i&, j%, C%, TT$, T1$, T3$, T4 As Date, T9$, N&, MC%
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([sheet1!I3], [sheet1!A65536].End(3))
With Sheets("¤u§@ªí1").[A1].Resize(UBound(Brr), UBound(Brr, 2))
   .Columns(1).NumberFormatLocal = "@"
   .Value = Brr
   .Sort KEY1:=.Item(1), Order1:=1, Key2:=.Item(4), Order2:=1, Header:=2
   Brr = .Value: Sheets("¤u§@ªí1").UsedRange.ClearContents
End With
ReDim Crr(1 To UBound(Brr), 1 To 100)
For i = 1 To UBound(Brr)
   If i = 1 Then
      Crr(1, 1) = "¤u¸¹": Crr(1, 2) = "©m¦W | Display Name": Crr(1, 3) = "¤Ñ¼Æ": N = 1
   End If
   T1 = Brr(i, 1): T3 = Brr(i, 3): T4 = Brr(i, 4): T9 = Brr(i, 9): TT = T1 & "|" & T3
   If T9 <> "°ê°²" Then GoTo i01
   If Y(TT) = "" Then N = N + 1: Y(TT) = N: Crr(N, 1) = T1: Crr(N, 2) = T3: Y(TT & "|C") = 3
   R = Y(TT): C = Y(TT & "|C"): C = C + 1: Y(TT & "|C") = C: If MC < C Then MC = C
   Crr(R, C) = T4: Crr(N, 3) = Crr(N, 3) + 1
i01: Next
For i = 4 To MC: Crr(1, i) = i - 3: Next
With Sheets("¤u§@ªí1")
   .Rows(1).NumberFormatLocal = "@": .[A1].Resize(N, MC) = Crr
End With
Set Y = Nothing: Erase Brr, Crr
End Sub
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

¦^´_ 9# Andy2483

Andy2483¤j¤j¯u¬O¤Ó±j¤F
­è­è¦³½Ð´X¦ì©j©j­Ì¬Ý¤F¤@¤U
³»¦h´N¬O¦rÅé»Ý­n¦bÀ°¦£©ñ¤j+²ÊÅé(½Ð§U²z¦Û¤v³B²z¤F)
¥Ø«e¨SÅ¥¨ì¥ô¦ó«s«èÁn

«D±`·PÁÂAndy2483¤j¤jªº¸Ñ´b

TOP

        ÀR«ä¦Û¦b : ÀR§¤±`®¦¤v¹L¡B¶¢½Í²ö½×¤H«D¡C
ªð¦^¦Cªí ¤W¤@¥DÃD