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

cowww

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

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

¤U¸ü (44.54 KB)

2023-5-26 08:16

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

¤U¸ü (10.47 KB)

2023-5-26 08:16

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


2023°ê°².zip (214.81 KB)

¤U¸ü¦¸¼Æ: 11

2023-5-26 08:22

Andy2483

¦^´_ 1# cowww


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

°õ¦æµ²ªG:

¤U¸ü (105.08 KB)

2023-5-26 09:22

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

cowww

¦^´_ 2# Andy2483


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

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

¤U¸ü (30.91 KB)

2023-5-26 09:58

Andy2483

¦^´_ 3# cowww


    ÁÂÁ«e½ú¦^´_
«e½úªººI¹Ï¸Ì¨C¦ì¾­û½Ð°²©ú²Ó¥u¦³°ê°²,¨ä¥¦°²§O¦p¦ó³B²z?
²£¥Xªº³øªí ¹ê»Ú¥Î³~¬O°µ¤°»ò¥Îªº?

cowww

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

Andy2483

¦^´_ 5# cowww


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

°õ¦æµ²ªG:

¤U¸ü (203.48 KB)

2023-5-26 11:51

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

cowww

¦^´_ 6# Andy2483

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

¤U¸ü (31.66 KB)

2023-5-26 13:12

¬°¦óªø©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·|¥Í®ðªº

Andy2483

¦^´_ 7# cowww


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

°õ¦æµ²ªG:

¤U¸ü (371.27 KB)

2023-5-26 14:03

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

Andy2483

¦^´_ 7# cowww


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

°õ¦æµ²ªG:

¤U¸ü (400.27 KB)

2023-5-26 14:32

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

cowww

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