[µo°Ý] 2±ø¥ó¤U°µ¸ê®Æ¾ã²z¬Û¥[

willeddie

¦U¦ì¤j«e½ú§A¦n
¥Ø«eªì¾ÇµÛ¡A·PÁ«ü±Ð

¤U¸ü (14.93 KB)

2022-12-29 10:53

­n±q¥ªÃä¨S¦³¾ã²z¹Lªº¸ê®Æ¡A®Ú¾Ú¦P¤é´Á²£«~ªº°µ¬Û¥[Á`¼Æ¦¨¥kÃ䪺ªí®æ
·PÁ«ü±Ð

Andy2483

¦^´_ 1# willeddie


    ÁÂÁ«e½úµoªí¦¹¥DÃD
«á¾ÇÂǦ¹©«½m²ß¦r¨å.¤Gºû°}¦C»P¤@ºû°}¦C,¹Lµ{.µ²ªG»Pµ{¦¡½X¦p¤U,½Ð¸Õ¸Õ¬Ý¬O§_²Å¦X»Ý¨D

¶Ã¼Æ²£¥Íªº½d¨Ò:

¤U¸ü (116.29 KB)

2022-12-29 14:06

°õ¦æµ²ªG:

¤U¸ü (145.27 KB)

2022-12-29 14:06

Option Explicit
Sub °}¦C»P¦r¨å½m²ß_2±ø¥ó¤U°µ¸ê®Æ¾ã²z¬Û¥[_FGÄæ±Æ§Ç()
Dim Y, Z, V, Arr, i, T(3)
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set V = CreateObject("Scripting.Dictionary")
Arr = Range([C2], [A65536].End(3))
For i = 1 To UBound(Arr)
   T(1) = DateValue(Arr(i, 1))
   T(2) = Arr(i, 2)
   T(3) = Arr(i, 3)
   T(0) = T(1) & "|" & T(2)
   Y(T(0)) = Y(T(0)) + T(3)
   Z(T(0)) = T(1)
   V(T(0)) = T(2)
Next
[F:H].ClearContents
[F2].Resize(Z.Count, 1) = Application.Transpose(Z.Items)
[G2].Resize(V.Count, 1) = Application.Transpose(V.Items)
[H2].Resize(Y.Count, 1) = Application.Transpose(Y.Items)
With [F2].Resize(Z.Count, 3)
   .Sort _
   KEY1:=.Item(1), Order1:=xlAscending, _
   Key2:=.Item(2), Order2:=xlAscending, _
   Header:=xlNo, Orientation:=xlTopToBottom
End With
[F1:H1] = [{"¤é´Á","²£«~","¼Æ¶q"}]
Set Y = Nothing
Set Z = Nothing
Set V = Nothing
Set Arr = Nothing
Erase T
End Sub

Sub ¶Ã¼Æ»s§@½d¨Ò_¤é´Á_²£«~_¼Æ¶q()
[A:C].ClearContents
[A1:C1] = [{"¤é´Á","²£«~","¼Æ¶q"}]
With [A2:A30]
   .Formula = "=IF(RAND()>.5,TODAY()+INT(RAND()*5),TODAY()+INT(RAND()*-5))"
   .Offset(, 1).Formula = "=MID(""ABC"",MOD(INT(RAND()*100),3)+1,1)"
   .Offset(, 2).Formula = "=IF(RAND()>.1,INT(RAND()*100),INT(RAND()*-100))"
   .Resize(, 3).Value = .Resize(, 3).Value
End With
End Sub

lee88

¦^´_ 2# Andy2483

1. Option Explicit
   
2. 
   
3. Sub ¸ê®Æ¾ã²z¬Û¥[()
   
4.     Dim D As Object, E As Range, B As Variant
   
5.     Set D = CreateObject("Scripting.Dictionary")
   
6.     For Each E In [A1:A30]     '  ¶Ã¼Æ»s§@½d¨Òªº¦s©ñ³B
   
7.         If Not D.exists(E & UCase(E.Range("b1"))) Then   '¦r¨åª«¥óªºkey(ÃöÁä¦r)   ¤£¦s¦b®É  (¤é´Á&²£«~)
   
8.             D(E & E.Range("b1")) = Array(E.Text, UCase(E.Range("b1")), E.Range("c1").Text)
   
9.             '¦r¨åª«¥ó(ÃöÁä¦r)ªºitem(¤º®e)  ¬°¤@ºû°}¦C
   
10.         Else
    
11.             B = D(E & UCase(E.Range("b1")))  'Ū¨ú¦r¨åª«¥ó(ÃöÁä¦r)ªºitem(¤º®e)
    
12.             B(2) = B(2) + E.Range("c1")              '¼Æ¶q¬Û¥[
    
13.             D(E & UCase(E.Range("b1"))) = B   '¦r¨åª«¥ó(ÃöÁä¦r)= «ü©w¤º®e
    
14.         End If
    
15.     Next
    
16.     With [H1].Resize(D.Count, 3)   '¾ã²z¬Û¥[¦s©ñ³B
    
17.         .Value = Application.Transpose(Application.Transpose(D.ItemS)) 'Âà¸m¤@ºû°}¦Cºû¤Gºû°}¦C
    
18.         .Sort KEY1:=.Cells(1), Order1:=1, KEY2:=.Cells(2), Order2:=1, Header:=xlYes
    
19.     End With
    
20. End Sub

½Æ»s¥N½X

samwang

¦^´_ 1# willeddie

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ
Sub test()
Dim Arr, xD, T$, n%
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([a1], [c65536].End(3))
For i = 1 To UBound(Arr)
    T = Arr(i, 1) & "|" & Arr(i, 2)
    If xD.Exists(T) Then
        Arr(xD(T), 3) = Arr(xD(T), 3) + Arr(i, 3)
    Else
        n = n + 1: xD(T) = n
        For j = 1 To 3: Arr(n, j) = Arr(i, j): Next
  End If
Next
With [f1].Resize(n, 3)
    .Value = Arr
   .Sort Key1:=.Item(1), Order1:=1, _
         Key2:=.Item(2), Order2:=1, Header:=1
End With
End Sub

hcm19522

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

Andy2483

¦^´_ 2# Andy2483


    ¦^´_¦Û¤v½Æ²ß¤ß±oµù¸Ñ
Option Explicit
Sub °}¦C»P¦r¨å½m²ß_2±ø¥ó¤U°µ¸ê®Æ¾ã²z¬Û¥[_FGÄæ±Æ§Ç()
Dim Y, Z, V, Arr, i&, T(3)
'¡ô«Å§iÅܼÆ:(Y,Z,V,Arr)¬O³q¥Î«¬ÅܼÆ,i¬Oªø¾ã¼Æ,T¬O¤@ºû°}¦CT(0)~T(3)
Set Y = CreateObject("Scripting.Dictionary")
Set Z = CreateObject("Scripting.Dictionary")
Set V = CreateObject("Scripting.Dictionary")
'¡ô¥OY,Z,V¦U¬O¦r¨å
Arr = Range([C2], [A65536].End(3))
'¡ô¥OArr¬O¤Gºû°}¦C!¥H[C2]¨ìAÄæ³Ì«á¦³¤º®eÀx¦s®æ,³o½d³òÀx¦s®æ­È­Ë¤J
For i = 1 To UBound(Arr)
'¡ô³]¶¶°j°é!i±q1¨ìArr°}¦C³Ì¦C¤j¯Á¤Þ¸¹¼Æ
   T(1) = DateValue(Arr(i, 1))
   '¡ô¥O1¯Á¤Þ¸¹T°}¦C­È¬O i°j°é¦C1ÄæArr°}¦C­ÈÂà¤é´Á®æ¦¡
   T(2) = Arr(i, 2)
   '¡ô¥O2¯Á¤Þ¸¹T°}¦C­È¬O i°j°é¦C2ÄæArr°}¦C­È
   T(3) = Arr(i, 3)
   '¡ô¥O3¯Á¤Þ¸¹T°}¦C­È¬O i°j°é¦C3ÄæArr°}¦C­È
   T(0) = T(1) & "|" & T(2)
   '¡ô¥O0¯Á¤Þ¸¹T°}¦C­È¬O 1¯Á¤Þ¸¹T°}¦C­È³s±µ "|" ¦A³s±µ2¯Á¤Þ¸¹T°}¦C­È
   Y(T(0)) = Y(T(0)) + T(3)
   '¡ô¥O¥H0¯Á¤Þ¸¹T°}¦C­È¬°Key,item¬O¦Û¨­+3¯Á¤Þ¸¹T°}¦C­È,­Ë¤JY¦r¨å
   Z(T(0)) = T(1)
   '¡ô¥O¥H0¯Á¤Þ¸¹T°}¦C­È¬°Key,1¯Á¤Þ¸¹T°}¦C­È,­Ë¤JZ¦r¨å
   V(T(0)) = T(2)
   '¡ô¥O¥H0¯Á¤Þ¸¹T°}¦C­È¬°Key,2¯Á¤Þ¸¹T°}¦C­È,­Ë¤JV¦r¨å
Next
[F:H].ClearContents
'¡ô²M°£F:HÄæÀx¦s®æ¤º®e
[F2].Resize(Z.Count, 1) = Application.Transpose(Z.ItemS)
'¡ô¥O[F2]ÂX®i¦V¤UZ¦r¨å¼Æ ¦V¥k¤£ÂX®i½d³òÀx¦s®æ¥HZ¦r¨åªºitemÂà¸m«á­Ë¤J
[G2].Resize(V.Count, 1) = Application.Transpose(V.ItemS)
'¡ôÃþ±À
[H2].Resize(Y.Count, 1) = Application.Transpose(Y.ItemS)
'¡ôÃþ±À
With [F2].Resize(Z.Count, 3)
'¡ô¥H¤U¬O Ãö©ó[F2]ÂX®i¦V¤UZ¦r¨å¼Æ ¦V¥k3Äæ½d³òÀx¦s®æ
   .Sort _
   KEY1:=.Item(1), Order1:=xlAscending, _
   KEY2:=.Item(2), Order2:=xlAscending, _
   Header:=xlNo, Orientation:=xlTopToBottom
    '¡ô¥O¥HÀx¦s®æ¶°²Ä1Äæ°µ²Ä¤@¼h°µµL¼ÐÃD¦Cªº¤W¤U¶¶±Æ§Ç,²Ä2Äæ¦P®É°µ²Ä¤G¼h¤W¤U¶¶±Æ§Ç
End With
[F1:H1] = [{"¤é´Á","²£«~","¼Æ¶q"}]
'¡ô¥OF1¨ìH1¤§¶¡ªºÀx¦s®æ¥H¦r¦ê±a¤J
Set Y = Nothing
Set Z = Nothing
Set V = Nothing
Set Arr = Nothing
Erase T
'¡ôÄÀ©ñÅܼÆ
End Sub

Andy2483

¦^´_ 3# lee88


    ÁÂÁ½׾Â,ÁÂÁ«e½ú
«á¾ÇÂǦ¹©«¾Ç²ß¨ì¤£¦P»yªk,¤ß±oµù¸Ñ¦p¤U,ÁÂÁ«e½ú

Option Explicit
Sub ¸ê®Æ¾ã²z¬Û¥[_lee88()
Dim D As Object, E As Range, B As Variant
'¡ô«Å§iÅܼÆ:D¬Oª«¥óÅܼÆ,E¬OÀx¦s®æÅܼÆ,B¬O³q¥Î«¬ÅܼÆ
Set D = CreateObject("Scripting.Dictionary")
'¡ô¥OD¬O ¦r¨å
For Each E In [A1:A30]
'¡ô³]°j°é!¥OE¬O [A1:A30]ªºÀx¦s®æ¤§¤@
   If Not D.exists(E & UCase(E.Range("b1"))) Then
   '¡ô¦pªG ¥HEÅܼÆÀx¦s®æ­È³s±µ(¥k1®æÀx¦s®æ­ÈÂà­^¤å¤j¼g)¦r¦ê,¥ÎExists ¤èªk§P©w,If¬OTrue
      D(E & E.Range("b1")) = Array(E.Text, UCase(E.Range("b1")), E.Range("c1").Text)
      '¦r¨åª«¥ó(ÃöÁä¦r)ªºitem(¤º®e)  ¬°¤@ºû°}¦C
      '¡ô¥O¥HEÅܼÆÀx¦s®æ­È³s±µ(¥k1®æÀx¦s®æ­È)¦r¦ê·íkey,ITEM¬O¤@ºû°}¦C,
      '±a¤J(EÅܼÆÀx¦s®æ­È,EÅܼÆÀx¦s®æ¥k1®æÀx¦s®æ­ÈÂà­^¤å¤j¼g,EÅܼÆÀx¦s®æ¥k2®æÀx¦s®æ­È)
      Else
         B = D(E & UCase(E.Range("b1")))
         'Ū¨ú¦r¨åª«¥ó(ÃöÁä¦r)ªºitem(¤º®e)
         '¡ô¥OB³o³q¥Î«¬ÅܼƬO ¥HEÅܼÆÀx¦s®æ­È³s±µ(¥k1®æÀx¦s®æ­ÈÂà­^¤å¤j¼g)¦r¦ê¬dD¦r¨åªºitem,
         '³oitem¬O¤@ºû°}¦C
         B(2) = B(2) + E.Range("c1")
         '¼Æ¶q¬Û¥[
         '¡ô¥O³o¤@ºû°}¦Cªº2¯Á¤Þ¸¹°}¦C­È¦Û¨­­È+ EÅܼÆÀx¦s®æ¥k2®æÀx¦s®æ­È
         D(E & UCase(E.Range("b1"))) = B
         '¦r¨åª«¥ó(ÃöÁä¦r)= «ü©w¤º®e
         '¡ô¥O³o¤@ºû°}¦C¦A©ñ¦^¦r¨å
   End If
Next
With [F1].Resize(D.Count, 3)
'¾ã²z¬Û¥[¦s©ñ³B
'¡ô¥H¤U¬O Ãö©ó[F1]ÂX®i¦V¤UD¦r¨å¼Æ ¦V¥k3Äæ½d³òÀx¦s®æ
   .Value = Application.Transpose(Application.Transpose(D.ItemS))
   'Âà¸m¤@ºû°}¦Cºû¤Gºû°}¦C
   '¡ô³o½d³òÀx¦s®æ­È¥H D¦r¨åªºitemÂà¸m2¦¸±a¤J
   .Sort KEY1:=.Cells(1), Order1:=1, KEY2:=.Cells(2), Order2:=1, Header:=xlYes
   '¡ô¥O¥HÀx¦s®æ¶°²Ä1Äæ°µ²Ä¤@¼h°µ¦³¼ÐÃD¦Cªº¤W¤U¶¶±Æ§Ç,²Ä2Äæ¦P®É°µ²Ä¤G¼h¤W¤U¶¶±Æ§Ç
End With
End Sub

Andy2483

¦^´_ 4# samwang


    ÁÂÁ«e½ú
«á¾ÇÂǦ¹©«°µ½Æ²ß¥H¦r¨å¬ö¿ýµ²ªG¸ê®Æ¦C¸¹ªº¤è¦¡³B²z ²Î­pµ²ªG
¤ß±oµù¸Ñ¦p¤U,ÁÂÁ«e½ú

Option Explicit
Sub test_samwang()
Dim Arr, xD, T$, n%, i&, j&
'¡ô«Å§iÅܼÆ:(Arr,xD)¬O³q¥Î«¬ÅܼÆ,T¬O¦r¦êÅܼÆ,n¬Oµu¾ã¼Æ,(i,j)¬Oªø¾ã¼Æ
Set xD = CreateObject("Scripting.Dictionary")
'¡ô¥OxD¬O ¦r¨å
Arr = Range([a1], [c65536].End(3))
'¡ô¥OArr¬O¤Gºû°}¦C!¥H[A1]¨ìCÄæ³Ì«á¦³¤º®eÀx¦s®æ½d³òÀx¦s®æ­È­Ë¤J
For i = 1 To UBound(Arr)
'¡ô³]¶¶°j°é!i±q1¨ìArr°}¦CÁa¦V³Ì¤j¯Á¤Þ¦C¸¹¼Æ
    T = Arr(i, 1) & "|" & Arr(i, 2)
    '¡ô¥OT¬Oi°j°é¦C1ÄæArr°}¦C­È³s±µ "|" ¦A³s±µ i°j°é¦C2ÄæArr°}¦C­È
    If xD.exists(T) Then
    '¡ô¦pªG¥HTÅÜ¼Æ ¥ÎExists ¤èªk¬dxD¦r¨å§P©w¬OTrue
        Arr(xD(T), 3) = Arr(xD(T), 3) + Arr(i, 3)
        '¡ô¥O¥HTÅܼƬdxD¦r¨å±o¨ìªºitem¼Æ¦r¬°¦C3ÄæArr°}¦C­È¬O¦Û¨­­È+i°j°é¦C3ÄæArr°}¦C­È
    Else
    '¡ô¥H¤U¬OIf±ø¥ó¤£¦¨¥ß¤~°õ¦æªºµ{§Ç
        n = n + 1: xD(T) = n
        '¡ô¥On³oµu¾ã¼ÆÅܼƲ֥[1 :¥O¥HTÅܼƷíkey,item¬OnÅܼƭˤJxD¦r¨å
        For j = 1 To 3: Arr(n, j) = Arr(i, j): Next
        '¡ô³]¶¶°j°é!j±q1¨ì3 :nÅܼƦCj°j°éÄæArr°}¦C­È¬O iÅܼƦCj°j°éÄæArr°}¦C­È
  End If
Next
With [F1].Resize(n, 3)
'¡ô¥H¤U¬O Ãö©ó[F1]ÂX®i¦V¤UnÅܼƦC ¦V¥k3Äæ½d³òÀx¦s®æ
    .Value = Arr
    '¡ô³o½d³òÀx¦s®æ­È¥HArr°}¦C­È±a¤J
   .Sort KEY1:=.Item(1), Order1:=1, _
         KEY2:=.Item(2), Order2:=1, Header:=1
   '¡ô¥O¥HÀx¦s®æ¶°²Ä1Äæ°µ²Ä¤@¼h°µ¦³¼ÐÃD¦Cªº¤W¤U¶¶±Æ§Ç,²Ä2Äæ¦P®É°µ²Ä¤G¼h¤W¤U¶¶±Æ§Ç
End With
End Sub

singo1232001

¦^´_ 1# willeddie


    Sub TEST()
Set cn = CreateObject("adodb.connection")
C = ".0; Data Source=" & ThisWorkbook.FullName
Select Case Application.Version
Case Is < 12: cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8" & C
Case Else: cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12" & C: End Select

q = "select ¤é´Á,²£«~,sum(¼Æ¶q) as ¼Æ¶q from [¤u§@ªí2$a1:C] "
q = q & "group by ¤é´Á,²£«~  having ¤é´Á is not null "

With Sheets("¤u§@ªí2"): .Range("F:H").ClearContents
Set rs = cn.Execute(q)
For i = 0 To rs.Fields.Count - 1 '¨ú¼ÐÃD¡A¦pªG¤£­n¥i¬Ù²¤
    .Cells(1, i + 6) = rs.Fields(i).Name
Next
.Cells(2, 6).CopyFromRecordset rs : End With
End Sub

singo1232001

¦^´_ 9# singo1232001

Sub TEST()
Select Case Application.Version
Case Is < 12: B = "Provider=Microsoft.Jet.OLEDB.4.0;Extended Properties=Excel 8"
Case Else: B = "Provider=Microsoft.ACE.OLEDB.12.0;Extended Properties=Excel 12": End Select
Set cn = CreateObject("adodb.connection")
cn.Open B & ".0; Data Source=" & ThisWorkbook.FullName
q = "select ¤é´Á,²£«~,sum(¼Æ¶q)from[¤u§@ªí2$a1:C]group by ¤é´Á,²£«~ having ¤é´Á is not null"
Set rs = cn.Execute(q)
[F:H].ClearContents: [F1:H1] = [A1:C1].Value
[F2].CopyFromRecordset rs
End Sub