[µo°Ý] ¸ê®Æ¾ã²z

ÅÚ½³ªd

¦U¦ì¤j¤j¦n¡A

¤p©f§Ú¾ã²z¸ê®Æ®É¥X²{¤F¤@­ÓÃøÃD¡A·Q½Ð¦U¦ìÀ°¦£³B²z
½s¸¹¸ò­ì®Æ¥i¯à¬Û¦P¦ý§å¸¹¤]³\¤£¦P(¸ê®Æsheet)¡A¦p¦ó§e²{¥X¥DºÞ·Q¬Ýªºªí³æ(§e²{ªísheets)
¥Ø«e¤½¦¡¥u¯à§ì¥X²Ä¤@µ§¡AµLªk§ì¨ì²Ä¤Gµ§§å¸¹¡A¦³¿ìªk¥i¥H¸Ñ¨M¶Ü¡H
¹ê»Ú¤W½s¸¹¬O100-300µ§
­ì®Æ¬OA-Z¡A¦ý¤£½T©w¦P½s¸¹+­ì®Æªº®Æ¸¹¦³´Xµ§
Á|¨Ò½s¸¹100­ì®ÆCªº®Æ¸¹¥Ø«e2µ§¡A¦ý¹ê»Ú¦³¥i¯à4-5µ§

samwang

¦^´_ 1# ÅÚ½³ªd

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁÂ
Sub test()
Dim Arr, Brr, xD, xD1, TT, n%, C%, m%, i&, k%
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Arr = Range([¸ê®Æ!c1], [¸ê®Æ!a65536].End(3))
For i = 2 To UBound(Arr)
    If Arr(i, 2) = "" Then GoTo 99
    If Not xD.Exists(Arr(i, 2) & "") Then
        k = k + 1: xD(Arr(i, 2) & "") = k
    End If
99: Next
ReDim Brr(1 To UBound(Arr), 1 To xD.Count + 1)
With Sheets("§e²{ªí")
    .Range("b1").Resize(, xD.Count) = xD.keys
    For i = 2 To UBound(Arr)
        C = xD(Arr(i, 2) & "") + 1
        If xD1.Exists(Arr(i, 1)) Then
            m = xD1(Arr(i, 1))
            If IsEmpty(Brr(m, C)) Then Brr(m, C) = Arr(i, 3) Else Brr(m, C) = Brr(m, C) & "," & Arr(i, 3)
        Else
            n = n + 1: xD1(Arr(i, 1)) = n
            Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
        End If
    Next
    .Range("a2").Resize(n, xD.Count) = Brr
End With
End Sub

hcm19522

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

ÅÚ½³ªd

¦^´_ 2# samwang


    ÁÂÁ¡A´ú¸Õok

ÅÚ½³ªd

¦^´_ 3# hcm19522


    ÁÂÁ¡A½Ð°Ý¦pªG¦b¤£ª¾¹D¦P¤@­ì®Æ¦³´Xµ§ªºª¬ºA¤U¬O¤£¬O³o¨ç¼Æ´NµLªk¨Ï¥Î¡H

samwang

¦^´_ 4# ÅÚ½³ªd


¤£¦n·N«ä¡A2#¦³­Ó¤p°ÝÃD¡A¥ÑxD.Count§ï¬°Ubound(Brr,2)¡A¦p¤U¬õ¦r³¡¤À¡AÁÂÁÂ

.Range("a8").Resize(n, UBound(Brr, 2)) = Brr

hcm19522

¦^´_ 5# ÅÚ½³ªd

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

samwang

¦^´_ 1# ÅÚ½³ªd

½Ð´ú¸Õ¬Ý¬Ý¡AÁÂÁ¡C

Sub ³æµ§¸ê®Æ()
Dim Arr, Brr, Crr(1 To 1, 1 To 100), xD, xD1, m%, m0%, m1%
Dim k0%, k1%, k%, ky, CMax, T$, n%, C%, C1%, i&
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
With Sheets("¸ê®Æ")
        With .Range(.[C1], .[a65536].End(xlUp))
            Brr = .Value
            .Sort Key1:=.Item(1), Order1:=xlAscending, _
                Key2:=.Item(2), Order2:=xlAscending, Header:=xlYes
            Arr = .Value
            .Value = Brr
        End With
End With
For i = 2 To UBound(Arr)
    If Arr(i, 2) = "" Then GoTo 97
    T = Arr(i, 1) & "_" & Arr(i, 2)
    If Not xD.Exists(T) Then '¨úÄæ¼Æ
        xD(Arr(i, 2) & "") = 1: xD(T) = ""
    Else
        k0 = xD(Arr(i, 2) & ""): k1 = xD1(Arr(i, 2) & "")
        If k0 > k1 Then k = k0 + 1 Else k = k1 + 1
        xD1(Arr(i, 2) & "") = k
    End If
97: Next
For Each ky In xD.keys    '¦C¥X²Ä¤@¦CªíÀY
    If InStr(ky, "_") Then GoTo 98
    If xD1.Exists(ky) Then
        For j = 1 To xD1(ky): y = y + 1: Crr(1, y) = ky: Next
    Else
        y = y + 1: Crr(1, y) = ky: s = s + 1
    End If
98: Next
xD1.RemoveAll
ReDim Brr(1 To UBound(Arr), 1 To y + 1)
With Sheets("§e²{ªí")
    .[a1:aa100] = ""
    .Range("b1").Resize(, y) = Crr
    For i = 2 To UBound(Arr)
        If Arr(i, 2) = "" Then GoTo 99
        C = Application.WorksheetFunction.Match(Arr(i, 2), Sheets(2).Range("a1").Resize(, y + 1), 0)
        If xD1.Exists(Arr(i, 1)) Then
            m = xD1(Arr(i, 1))
            If IsEmpty(Brr(m, C)) Then
                Brr(m, C) = Arr(i, 3)
            Else
                If m0 = 0 Then m0 = m
                If m0 <> m Then C1 = 0
                If C1 > C Then C1 = C1 + 1 Else C1 = C + 1
                Brr(m, C1) = Arr(i, 3)
            End If
        Else
            n = n + 1: xD1(Arr(i, 1)) = n
            Brr(n, 1) = Arr(i, 1): Brr(n, C) = Arr(i, 3)
        End If
99: Next
    .Range("a2").Resize(n, y + 1) = Brr
End With
End Sub

­ã´£³¡ªL

VBAªþÀÉ:
Xl0000805.rar (12.08 KB)

¤U¸ü¦¸¼Æ: 8

2021-11-6 19:00

®ÄªG:

¤U¸ü (8.23 KB)

2021-11-6 19:01

Andy2483

¦^´_ 9# ­ã´£³¡ªL
'ÁÂÁ«e½ú
'³o©«²ß±o¦h¼Ëª¾ÃÑ
'1.Range([¸ê®Æ!c1], [¸ê®Æ!a1].Cells(Rows.Count, 1).End(xlUp))
'  ¬Ý¦ü²³æªºÀx¦s®æ½d³ò!¾Ç¨ì¤F [¸ê®Æ!c1] ·|ÅýRange()«ü¦V ¸ê®Æªí
'  ¥H«e»~¥H¬° ¨S¦³¤u§@ªí«ü¦VªºRange() ¤@©w¬O¦bActiveSheet
'  §_«h¤@©w­n«ü¦V­þ­Óªí Sheets("¸ê®Æ").Range()
'2.«e½ú«Ü¦³¤ß³£·|¥Î¤£¦Pªº»yªk±Òµo«á¾Ç­Ì!¤£¬O¾÷±ñ¦¡ªº¦^µª!ÁÂÁÂ!
'3.Format(T(3), "0000") ¾Ç²ß¨ì¦p¦ó¼Æ¦r¸É¨¬«e¤èªº0 ¦¨¬°·Q­nªº¼Æ¦r½X¼Æ
'4.¥Î¦r¨å»P°}¦C ¾Q³¯¼ÐÃD¦C»P¼ÐÃDÄæ ¦n¹³¤w¸g¬ÝÀ´! ¦ý¤S¤£·|¥Î!¦A¶Ô½m¬Ý¬Ý!
'5.¾Ç¨ì Äæ±Æ§Ç
'6.¾Ç¨ì ¥h°£ "|"²Å¸¹(§t)¥kÃ䪺¦r¤¸  Replace "|*", "", Lookat:=xlPart
'7.¾Ç¨ì ¯d¤U[A1]Àx¦s®æ!¨ä¾lÀx¦s®æ§R°£
'8.±×½uÀHÀx¦s®æÁY©ñ

¤@¶}©l¶K¤J:

¤U¸ü (30.28 KB)

2022-10-27 14:32

Äæ±Æ§Ç:

¤U¸ü (30.46 KB)

2022-10-27 14:32

¦C±Æ§Ç:

¤U¸ü (30.2 KB)

2022-10-27 14:33

¼ÐÃD¦C¯d­ì®Æ»PÅã¥Ü®æ½u:

¤U¸ü (32.25 KB)

2022-10-27 14:33

±×½uÀHÀx¦s®æÁY©ñ:

¤U¸ü (113.62 KB)

2022-10-27 14:44

¥H¤U¤ß±oµù¸Ñ½Ð«e½ú¦A«ü±Ð!ÁÂÁ«e½ú
Sub TEST_A1()
Dim Arr, Brr, xD, T$(3), i&, j%, R&, C%, X&, Y%
'¡ô«Å§iÅܼÆ,§å¦¸«Å§iT¬O¦r¦êÅÜ¼Æ T(0)~T(3)
Call ²M°£
'¡ô°õ¦æ°Æµ{¦¡ ²M°£()

Set xD = CreateObject("Scripting.Dictionary")
'¡ô¥O xD¬O¦r¨å
Arr = Range([¸ê®Æ!c1], [¸ê®Æ!a1].Cells(Rows.Count, 1).End(xlUp))
'¡ô¥O Arr¬O°}¦C,­Ë¤J ¸ê®Æªí¸ÌC1¨ìAÄæ³Ì«á¤@­Ó¦³¤º®eÀx¦s®æ
'³o¨â­ÓÀx¦s®æ¶¡ÂX®i¨ì³Ì¤p¤è¥¿°Ï°ìÀx¦s®æªº­È
ReDim Brr(1 To UBound(Arr), 1 To 200)
'¡ô«Å§i Brr°}¦Cªº½d³ò! Áa¦V¬O1 ¨ì Arr°}¦Cªº¦C¼Æ
'¾î¦V¬O1 ¨ì 200 Äæ¼Æ
For i = 2 To UBound(Arr)
'¡ô³]¥~¶¶°j°é ±q2 ¨ì Arr°}¦C³Ì«á¦C¼Æ
    For j = 1 To 3
    '¡ô³]¤º¶¶°j°é ±q1 ¨ì3
        T(j) = Arr(i, j)
        '¡ô¥O°j°é¤¤ T¦r¦êÅܼƸˤJArr°}¦C¹ïÀ³­È
        If T(j) = "" Then
        '¡ô¦pªG ¦¹¤º°j°é¤¤ T¦r¦êÅÜ¼Æ ¸Ë¤J¤FªÅ®æ
           GoTo 101
           '¡ô±ø¥ó¦¨¥ß!´N¸õ¨ì 101 Ä~Äò°õ¦æ
        End If
    Next j
    T(0) = T(2) & "|" & Format(T(3), "0000")
    '¡ô¥O²Ä1­ÓT¦r¦êÅܼƬO ²Ä3­ÓT¦r¦êÅÜ¼Æ & "|" & ²Ä4­ÓT¦r¦ê(4½X¼Æ¦r)
    X = xD(T(1))
    '¡ô¥OX¼Æ¦rÅܼƬO xD¦r¨å¸Ì¥H ²Ä2­ÓT¦r¦ê ­È¬°keyªºitem
    '¤@¶}©l¬O¬d¤£¨ì item!¦ý¬O¦r¨å¸Ì¤w¸g¦¬¯Ç¤F ²Ä2­ÓT¦r¦ê ­È¬°key
    '¦]¬°X¼Æ¦rÅܼÆ!¬d¤£¨ì´N¬Oªì©l­È0
    Y = xD(T(0))
    '¡ô¥OY¼Æ¦rÅܼƬO xD¦r¨å¸Ì¥H ²Ä1­ÓT¦r¦ê ­È¬°keyªºitem
    '¤@¶}©l¤]¬O¬d¤£¨ì item!¦ý¬O¦r¨å¸Ì¤w¸g¦¬¯Ç¤F ²Ä1­ÓT¦r¦ê ­È¬°key
    '¦]¬°Y¼Æ¦rÅܼÆ!¬d¤£¨ì´N¬Oªì©l­È0
    If X = 0 Then
    '¡ô¦pªGX¼Æ¦rÅܼƬOªì©l­È0
       R = R + 1
       '¡ô±ø¥ó¦¨¥ß!R¼Æ¦rÅܼƴN²Ö¥[ 1
       X = R + 1
       '¡ô±ø¥ó¦¨¥ß!X¼Æ¦rÅܼƤS¥HR¼Æ¦rÅܼƦA +1
       '¦]¬°¼ÐÃDÄæ¬O±q©¹¤U²Ä2­Ó¶}©l
       xD(T(1)) = X
       '¡ô¥O xD¦r¨å¤¤ ²Ä2­ÓT¦r¦êÅܼÆ(½s¸¹) ¬°keyªºitem = X¼Æ¦rÅܼÆ
       '©Ò¥H¶}©l¸Ë¤Jªºitem¬O ¼Æ¦r2
       Brr(X, 1) = T(1)
       '¡ô¤@¶}©l¬O¥OBrr°}¦C²Ä2¦C²Ä1Äæ¬O ²Ä2­ÓT¦r¦êÅܼÆ(½s¸¹)
       '¡ô³o¬O¼ÐÃDÄæ
    End If
    If Y = 0 Then
    '¡ô¦pªGY¼Æ¦rÅܼƬOªì©l­È0
       C = C + 1
       '¡ô±ø¥ó¦¨¥ß!C¼Æ¦rÅܼƴN²Ö¥[ 1
       Y = C + 1
       '¡ô±ø¥ó¦¨¥ß!Y¼Æ¦rÅܼƤS¥HC¼Æ¦rÅܼƦA +1
       '¦]¬°¼ÐÃD¦C¬O±q©¹¥k²Ä2­Ó¶}©l
       xD(T(0)) = Y
       '¡ô¥O xD¦r¨å¤¤ (­ì®Æ)& "|" &(§å¸¹) ¬°keyªºitem = Y¼Æ¦rÅܼÆ
       Brr(1, Y) = T(0)
       '¡ô¤@¶}©l¬O¥OBrr°}¦C²Ä1¦C²Ä2Äæ¬O ²Ä1­ÓT¦r¦êÅÜ¼Æ (­ì®Æ)& "|" &(§å¸¹)
       '¡ô³o¬O¼ÐÃD¦C
    End If
    Brr(X, Y) = T(3)
    '¡ô¼ÐÃD¦CÄæ©Ò¹ïÀ³ªº §å¸¹©ñ¤J Brr°}¦C¤¤
101: Next i
Brr(1, 1) = "¡@¡@¡@­ì®Æ¡@½s¸¹"
'¡ô¥OBrr°}¦C²Ä1¦C²Ä1ÄæÀx¦s®æªº¦r¦ê
With [§e²{ªí!A1].Resize(R + 1, C + 1)
'¡ôR¬O¤£¥]§t¼ÐÃD¦C!©Ò¥H­n +1 ,C¬O¤£¥]§t¼ÐÃDÄæ!©Ò¥H­n +1
    .Value = Brr
    '¡ô±NBrr°}¦C±q §e²{ªí[A1]¶K¤J­È
    .Columns(2).Resize(, C).Sort Key1:=.Cells(1, 2), Order1:=xlAscending, Header:=xlNo, Orientation:=xlLeftToRight
    '¡ôÄæ¥H¼ÐÃD¦C±Æ§Ç
    .Rows(2).Resize(R).Sort Key1:=.Cells(2, 1), Order1:=xlAscending, Header:=xlNo, Orientation:=xlTopToBottom
    '¡ô¦C¥H¼ÐÃDÄæ±Æ§Ç
    .Rows(1).Replace "|*", "", Lookat:=xlPart
    '¡ô§â¼ÐÃD¦C¥h°£ "|"²Å¸¹(§t)¥kÃ䪺¦r¤¸!¼ÐÃD¦C³Ñ¤U (­ì®Æ)
    .Borders.LineStyle = 1
    '¡ôÅýÀx¦s®æ®æ½uÅã¥Ü ²Ó¹ê½u
End With
End Sub

Sub ²M°£()
With Sheets("§e²{ªí").UsedRange
    .Offset(1, 0).EntireRow.Delete
    .Offset(, 1).EntireColumn.Delete
    '¯d¤U[A1]Àx¦s®æ!¨ä¾lÀx¦s®æ§R°£
End With
End Sub