[µo°Ý]§R°£¤£­«½Æªº¸ê®Æ,¥u¯d¤U­«½Æªº¸ê°T

boblovejoyce

ª¦¤å¤F30¤ÀÄÁ~¬Ý¨ìªº¸ê°T³£¬O§R°£­«½Æªº©~¦h
¤]¦³«O¯d­«½Æ¸ê®Æªº¤å³¹,¨Ò¦p:
http://forum.twbts.com/viewthrea ... hlight=%AD%AB%BD%C6

¦p¤U¹Ï¤ù~¦]¬°¬O¨Ì·Ó®y¼ÐX©MY,©Ò¥H·Q­n¯d¤U­«½Æªº@@
¤Ï¦Ó¤£­«½Æªº,Åܦ¨¤£·Q­nªº
³o¼Ë¥i¥H³B²z¶Ü?¯à§_µ¹­Ó·N¨£¤è¦¡

¥Ø«e¬O¨Ï¥Î±NXYªºÀx¦s®æ &°_¨Ó«á,µM«á¦A¥Î¤j®a±Ô­zªºcountif,µM«á¦b±Æ§Ç¦b¿z¿ï~
¥i¬O³o¼Ë¹Lµ{¦ü¥G«ÜÃlªø~@@

¤U¸ü (55.31 KB)

2015-9-23 23:39

«O¯d­«½Æªº¸ê®Æ.rar (7.17 KB)

¤U¸ü¦¸¼Æ: 8

2015-9-23 23:33

GBKEE

¦^´_ 1# boblovejoyce
¸Õ¸Õ¬Ý

1. Option Explicit
   
2. Sub EX()
   
3.     Dim D As Object, DD As Object, E As Variant, Ar(), S As String, i As Integer
   
4.     Set D = CreateObject("SCRIPTING.DICTIONARY")
   
5.     'Dictionary ª«¥ó»P PERL ¬ÛÃö°}¦C¥þµ¥¡C¥i¥H¬O¥ô¦ó«¬¦¡ªº¸ê®Æªº¶µ¥Ø³QÀx¦s¦b°}¦C¤¤¡C¨C­Ó¶µ¥Ø³£»P¤@­Ó°ß¤@ªºÃöÁä¦r¬ÛÃö¡C¸ÓÃöÁä¦r¥Î¨Ó¨ú¥X³æ­Ó¶µ¥Ø¡A³q±`¬O¾ã¼Æ©Î¦r¦ê¡A¥i¥H¬O°£°}¦C¥~ªº¥ô¦ó«¬ºA¡C
   
6.     Set DD = CreateObject("SCRIPTING.DICTIONARY")
   
7.     With Range("A1").CurrentRegion
   
8.     'CurrentRegion ÄÝ©Ê ¶Ç¦^ Range ª«¥ó¡A¸Óª«¥ó¥Nªí¥Ø«eªº°Ï°ì¡C¥Ø«e°Ï°ì¬O«ü¥H¥ô·NªÅ¥Õ¦C¤ÎªÅ¥ÕÄ檺²Õ¦X¬°Ãä¬Éªº½d³ò¡C°ßŪ¡C
   
9.         For Each E In .Rows
   
10.             S = E.Cells(1, 2) & "-" & E.Cells(1, 3)
    
11.             If D.Exists(S) Then      '¦r¨åª«¥ó ªºÃöÁä¦r¦s¦b
    
12.                 Ar = D(S)
    
13.                 ReDim Preserve Ar(1 To 3, 1 To UBound(Ar, 2) + 1)
    
14.                 'Preserve ¿ï¾Ü©Ê¤Þ¼Æ¡C·í§ïÅܭ즳°}¦C³Ì«á¤@ºûªº¤j¤p®É¡A¤´µM«O¦³­ì¨Óªº¸ê®ÆªºÃöÁä¦r¡C
    
15.                 For i = 1 To 3
    
16.                     Ar(i, UBound(Ar, 2)) = E.Cells(1, i)
    
17.                 Next
    
18.                 D(S) = Ar
    
19.                 DD(S) = Ar
    
20.             Else
    
21.                 D(S) = Application.Transpose(E)
    
22.             End If
    
23.         Next
    
24.     End With
    
25.     For Each E In DD.ITEMS  '¦r¨åª«¥óªº¶µ¥Ø
    
26.         With Range("F" & Rows.Count).End(xlUp).Offset(1)
    
27.             Ar = Application.Transpose(E)
    
28.             .Resize(UBound(Ar), 3) = Ar
    
29.         End With
    
30.     Next
    
31. End Sub

½Æ»s¥N½X

Andy2483

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

°õ¦æ«e:

¤U¸ü (79.44 KB)

2023-4-27 15:47

°õ¦æµ²ªG:

¤U¸ü (86.71 KB)

2023-4-27 15:48

Option Explicit
Sub TEST()
Dim Brr, Crr(1 To 100, 1 To 3), A, Y, i&, j%, T1$, T2$, T3$, TT$, N%
Dim xR As Range, Ra As Range, Sh As Worksheet, xBook As Workbook
Set Y = CreateObject("Scripting.Dictionary")
Brr = Range([C1], Cells(Rows.Count, 1).End(3))
For i = 2 To UBound(Brr)
   T1 = Brr(i, 1): T2 = Brr(i, 2): T3 = Brr(i, 3): TT = T2 & "/" & T3
   A = Y(TT): N = Y(TT & "|R"): N = N + 1
   If Not IsArray(A) Then A = Crr
   For j = 1 To 3: A(N, j) = Brr(i, j): Next
   Y(TT) = A: Y(TT & "|R") = N
Next
[K:M].ClearContents: [K1:M1] = [{"«¬¸¹","®y¼ÐX","®y¼ÐY"}]: N = 2
For Each A In Y.KEYS
   If InStr(A, "|") Then GoTo i01
   If Y(A & "|R") = 1 Then GoTo i01
   Cells(N, "K").Resize(Y(A & "|R"), 3) = Y(A)
   N = N + Y(A & "|R")
i01: Next
Set Y = Nothing: Erase Brr, Crr
End Sub