[µo°Ý] §Q¥ÎEXCEL¥¨¶°¸ê®Æ³B²z EXCEL, ¥¨¶°

¤Ñ´P

¦p¦ó­×§ï¥H¤U§», §âµ²ªG±qÄæ¦ì"­q³f³æ" ¶}©l¶K¦bresult ¤W?

Sub nn()
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
With Sheet1
For Each a In .Range(.[A2], .[A65536].End(xlUp))
mystr = a.Offset(, 1) & a.Offset(, 2) & a.Offset(, 3) & a.Offset(, 4) & a.Offset(, 5)
¡@ If IsEmpty(d(mystr)) Then
¡@¡@¡@ar = a.Resize(, 6).Value
¡@¡@¡@d(mystr) = a.Resize(, 6).Value
¡@¡@¡@d1(mystr) = 1
¡@¡@¡@Else
¡@¡@¡@ar = d(mystr)
¡@¡@¡@ar(1, 6) = ar(1, 6) + Val(a.Offset(, 5))
¡@¡@¡@d1(mystr) = d1(mystr) + 1
¡@¡@End If
Next
End With
With Sheet2
¡@ .[A2:G65536] = ""
¡@ .[A2].Resize(d.Count, 6) = Application.Transpose(Application.Transpose(d.items))
¡@ .[G2].Resize(d.Count, 1) = Application.Transpose(d1.items)
End With
End Sub

Andy2483

ÁÂÁ½׾Â,ÁÂÁ¦U¦ì«e½ú
«á¾ÇÂǦ¹©«½m²ß°}¦C»P¦r¨å,¾Ç²ß¤è®×¦p¤U,½Ð¦U¦ì«e½ú«ü±Ð

¸ê®Æªí:

¤U¸ü (147.76 KB)

2023-5-15 11:43

µ²ªGªí:

¤U¸ü (90.54 KB)

2023-5-15 11:43

Option Explicit
Sub TEST()
Dim Brr, Crr, Y, R1&, R&, i&, j&, TT$, T2$, T3$, T4$, T5$
'¡ô«Å§iÅܼÆ
Set Y = CreateObject("Scripting.Dictionary")
'¡ô¥OYÅܼƬO ¦r¨å
Brr = Range([Date!F2], [Date!A65536].End(xlUp))
'¡ô¥OBrrÅܼƬO ¤Gºû°}¦C,¥H¸ê®ÆªíÀx¦s®æ­È±a¤J
ReDim Crr(1 To 1000, 1 To 7)
'¡ô«Å§iCrrÅܼƬO¤GºûªÅ°}¦C,Áa¦V¯Á¤Þ¸¹1~1000,¾î¦V1~7
For i = 1 To UBound(Brr)
'¡ô³]¶¶°j°é
   T2 = Brr(i, 2): T3 = Brr(i, 3): T4 = Brr(i, 4): T5 = Brr(i, 5)
   '¡ô¥OT2~T5ÅܼƸˤJ°}¦C­È
   TT = T2 & "|" & T3 & "|" & T4 & "|" & T5
   '¡ô¥OTTÅܼƬO²Õ¦X¦r¦ê,¥Î¨ÓÂo­«½Æ¥Îªºkey
   If Y(TT) = "" Then
   '¡ô¦pªG¥HTTÅܼƬdY¦r¨å±oitem­È¬O""
      R = R + 1
      '¡ô¥ORÅܼƲ֥[1 (¥Î¨Ó²Ö¥[Crr°}¦C³oµ²ªG°}¦Cªº¦C¸¹)
      For j = 1 To 4: Crr(R, j) = Brr(i, j + 1): Next
      '¡ô±NBrr°}¦C2~5Äæ¼g¤JCrr°}¦C(1~4)Äæ«ü©wªºRÅܼƦC¸¹
      Crr(R, 5) = Val(Brr(i, 6))
      '¡ôCrr°}¦C²Ä5Äæ©ñ¤J¸ê®Æªíªº¼Æ¶q (¥ÎVal()±N¦r¦êÂର¼Æ­È)
      Crr(R, 6) = 1
      '¡ôCrr°}¦C²Ä6Äæ¬O¼g¤J1  (²Ä1½c)
      Crr(R, 7) = Brr(i, 1)
      '¡ôCrr°}¦C²Ä7Äæ¬O¼g¤J½c¸¹ (²Ä1½c¸¹)
      Y(TT) = R: GoTo i01
      '¡ô¥O¥HTTÅܼƬ°key,item¬O RÅܼÆ(¦C¸¹),¯Ç¤JY¦r¨å¤¤
      '¥Oµ{§Ç¸õ¨ì¼Ð¥Ü i01¦ì¸mÄ~Äò°õ¦æ
   End If
   R1 = Y(TT)
   '¡ô¥OR1ÅܼƬO ¥HTTÅܼƬdY¦r¨å±oitem­È (¥Î¨Ó«ü¦VCrr°}¦C¦C¸¹)
   '¬O²Ä2¦¸¥H¤W¥X²{ªºkey¤~·|¶]¨ì³o¸Ì
   Crr(R1, 5) = Crr(R1, 5) + Val(Brr(i, 6))
   '¡ô¥O¼Æ¶q²Ö¥[
   Crr(R1, 6) = Crr(R1, 6) + 1
   '¡ô¥O½c¼Æ²Ö¥[
   Crr(R1, 7) = Crr(R1, 7) & "," & Brr(i, 1)
   '¡ô¥O½c¸¹²K¥[¦bCrr°}¦C²Ä7Äæ«á­±
i01: Next
With [Result!A2].Resize(R, 7)
'¡ô¥H¤U¬OÃö©óµ²ªGªí¹w­p­n¼g¤J·sµ²ªG½d³òÀx¦s®æªºµ{§Ç
   .EntireColumn.Clear
   '¡ô¥O³o¨ÇÄæ¦ì°µ²M°£
   [Result!A1:G1] = [{"­q³f³æ","ªO¸¹","®Æ¸¹","­ì²£¦a","¼Æ¶q¦X­p","½c¼Æ","½c¸¹µù°O"}]
   '¡ô¥Oµ²ªGªí¼g¤J¼ÐÃD¦C
   .Value = Crr
   '¡ô¥OCrr°}¦C­È¼g¤J³o¨Ç½d³òÀx¦s®æ,¶W¹L¦¹½d³òªº°}¦C­È©¿²¤
   .EntireColumn.AutoFit
   '¡ô¥O³o¨ÇÄæ¦ìÄæ¼e¦Û°Ê½Õ¾ã
   Intersect(.Cells, [G:G]).NumberFormatLocal = "@"
   '¡ô¥O²Ä7Ä檺®æ¦¡¬O ¤å¦r
End With
Set Y = Nothing: Erase Brr, Crr
'¡ô¥OÄÀ©ñÅܼÆ
End Sub

Hsieh

¦^´_ 5# luhpro


    ³oÃä­ì·Q­n®M¥Î Join ¤èªk¦ý·f°t Cells ¤@ª½³£»¡ "°õ¦æ¿ù»~", ©Ò¥H¥u¯à¼È®É¥ý³o¼Ë¥ÎÅo.
³o¬O¦]¬°·í§A«ü©w¤@¦Cªº½d³ò°µ°}¦C®É
¨Æ¹ê¤Wexcel§â¦¹½d³ò¬Ý¦¨2ºû°}¦C
¦Ójoin¨ç¼Æªº°Ñ¼Æ¥u¯à¤¹³\¤@ºû°}¦C

¤Ñ´P

¸ÕÅç«á. ³£¬O .Dictionary ¸û§Ö, Split(Text, "-")<< ¸û¯Ó®É, ÁÂÁ¦U¤j¤j!

GBKEE

¦^´_ 5# luhpro
Vba ªº¸Ñªk¦³³\¦h ºÝ¬Ý­Ó¤H³ß¦n
Sub Ex()
    Dim Ar(), j%, Text$, R
    Sheets("Result").Range("A2:G65536").Clear
    With Sheets("Date")
        ReDim Ar(0)
        Ar(0) = Join(Application.Transpose(Application.Transpose(.[A1].Resize(1, 5))), "-")
        For j = 2 To .Range("B65536").End(xlUp).Row
        ' ®M¥Î Join ¤èªk·f°t Cells
            Text = Join(Application.Transpose(Application.Transpose(.Cells(j, "B").Resize(1, 5))), "-")
            R = Application.Match(Text, Ar, 0)
            With Sheets("Result")
                If Not IsNumeric(R) Then
                    ReDim Preserve Ar(UBound(Ar) + 1)
                    Ar(UBound(Ar)) = Text
                    .Cells(UBound(Ar) + 1, "A").Resize(1, 5) = Split(Text, "-")
                    .Cells(UBound(Ar) + 1, "F") = 1
                Else
                    .Cells(R, "F") = .Cells(R, "F") + 1
                End If
            End With
        Next j
    End With
End Sub

GBKEE

¦^´_ 4# ¤Ñ´P
Sub Ex()
    Dim D As Object, A As Range, Ar1(), Ar2()
    Set D = CreateObject("Scripting.Dictionary")
    With Sheets("Date")
        For Each A In .Range(.[b2], .[b65536].End(xlUp))
            Ar1 = Application.Transpose(Application.Transpose(A.Resize(, 5).Value))
            Ar2 = Application.Transpose(Application.Transpose(A.Resize(, 6).Value))
            If D.EXISTS(Join(Ar1, "")) Then
                Ar2(6) = D(Join(Ar1, ""))(6) + 1
                D(Join(Ar1, "")) = Ar2
            Else
                Ar2(6) = 1
                D(Join(Ar1, "")) = Ar2
            End If
        Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Result")
        .Range("a1").CurrentRegion.Offset(1) = ""
        .[A2].Resize(D.Count, 6) = Application.Transpose(Application.Transpose(D.items))
    End With
    Application.ScreenUpdating = True
End Sub

luhpro

§Úı±o³o­Ó Case ¤£¨Ï¥Î Dictionary ¤Ï¦Ó¥i¯à·|§ó§Ö©O, µ{¦¡¦p¤U :

Sub Ex()
    Dim i%, j%, iSou%, iRes%, Text$
    Dim rC As Range
   
    Sheets("Result").Range("A2:G65536").Clear
   
    iRes = 2
    With Sheets("Date")
      iSou = .Range("B65536").End(xlUp).Row
      
      For j = 2 To iSou
      ' ³oÃä­ì·Q­n®M¥Î Join ¤èªk¦ý·f°t Cells ¤@ª½³£»¡ "°õ¦æ¿ù»~", ©Ò¥H¥u¯à¼È®É¥ý³o¼Ë¥ÎÅo.
      Text = .Cells(j, 2) & "-" & .Cells(j, 3) & "-" & .Cells(j, 4) & "-" & .Cells(j, 5) & "-" & .Cells(j, 6)
               
        With Sheets("Result")
          Set rC = .Range(.Cells(2, 7), .Cells(iRes, 7)).Find(Text, LookIn:=xlValues)
         
          If Not rC Is Nothing Then
            i = rC.Row
            .Cells(i, 6) = .Cells(i, 6) + 1
          Else
            .Cells(iRes, 7) = Text
            .Cells(iRes, "A").Resize(, 5) = Split(Text, "-")
            .Cells(iRes, 6) = 1
            iRes = iRes + 1
          End If
        
        End With
      Next j
      
    End With
  Sheets("Result").Range("G2:G65536").Clear
End Sub

¤Ñ´P

¤w­×§ï¦¨³o¥y, ¥i¥H¹F¨ì¥Ø¼Ð, ¦ý³v¦æ¶K¤W, ³t«×¤ÓºC, ¥i¥H²¤Æ¶Ü

For i = 1 To D.Count
.Cells(1 + i, 1).Resize(1, 1) = Application.Transpose(Application.Transpose(D.items))(i, 4)
NEXT

GBKEE

¦^´_ 1# ¤Ñ´P
    Sub Ex()
    Dim A, Text$, i%
    Set d = CreateObject("Scripting.Dictionary")
    With Sheets("Date")
        For Each A In .Range(.[b2], .[b65536].End(xlUp))
        Text = Join(Application.Transpose(Application.Transpose(A.Resize(, 5).Value)), "-")
        If d.EXISTS(Text) Then
            d(Text) = d(Text) + 1
        Else
            d(Text) = 1
        End If
    Next
    End With
    Application.ScreenUpdating = False
    With Sheets("Result")
        .Range("a1").CurrentRegion.Offset(1) = ""
        i = 2
        For Each A In d.keys
            .Cells(i, "A").Resize(, 5) = Split(A, "-")
            .Cells(i, "F") = d(A)
            i = i + 1
        Next
    End With
    Application.ScreenUpdating = True
End Sub

Hsieh

§A¦Û¤v¨SÀ|¸Õ¥h§ï§ï¬Ý¶Ü?
¤F¸Ñ¾ãÅé¬yµ{»yªkªº·N¸q«á
­n­×§ï¨Ã¤£§xÃø
§AÀ³¸Ó§â§A­×§ï¹Lµ{¤¤µLªk§JªAªº¦a¤è®³¥X¨Ó°Q½×
¦Ó«D­n§O¤Hª½±µ­×¦nµ¹§A
Sub nn()
Dim d As Object, d1 As Object, a As Range, mystr As String
Set d = CreateObject("Scripting.Dictionary")
Set d1 = CreateObject("Scripting.Dictionary")
t = Timer
With Sheet1
For Each a In .Range(.[A2], .[A65536].End(xlUp))
mystr = Join(Application.Transpose(Application.Transpose(a.Offset(, 1).Resize(, 5))), "")
   If IsEmpty(d(mystr)) Then
      Ar = a.Offset(, 1).Resize(, 5).Value
      d(mystr) = a.Offset(, 1).Resize(, 5).Value
      d1(mystr) = 1
      Else
      Ar = d(mystr)
      Ar(1, 5) = Ar(1, 5) + Val(a.Offset(, 5))
      d1(mystr) = d1(mystr) + 1
    End If
Next
End With
With Sheet2
   .[A2:F65536] = ""
   .[A2].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.items))
   .[F2].Resize(d.Count, 1) = Application.Transpose(d1.items)
End With
Application.ScreenUpdating = True
MsgBox Timer - t
End Sub