½Ð±Ð¤@­ÓVBA±Æ§Ç°ÝÃD

tonycho33

½Ð°Ý¤@¤U§Ú¥Ø«e¦³¤T­Ó¸ê®Æ WW,XX,YY¦U¦³±a¥Xªº¸ê®ÆA1,A2,A3,A4,A5
¦pªG·Q¥HA1,A2,A3,A4,A5¬°¤ÀÃþ±Æ§ÇWW,XX,YY,¥B»Ý«ö·Ó¶¶§Ç1,2,3¤U¨Ó
­n¦p¦ó¼gVBA©O

Hsieh

¦^´_ 1# tonycho33

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5:H5,C7:H7,C9:H9").SpecialCells(xlCellTypeConstants)
   
4.    If IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2)
   
5. Next
   
6. For Each a In [K5:K9]
   
7. ar = Split(d(a.Value), ",")
   
8.    a.Offset(, 1).Resize(, UBound(ar) + 1) = ar
   
9. Next
   
10. End Sub

½Æ»s¥N½X

tonycho33

¦^´_ 2# Hsieh


    ½Ð°Ý¥i¥H¸ÑÄÀ¤@¤U¶Ü¡H
¦pªG§Úªº­ì©l¸ê®ÆÄæ¦ì¦³·s¼W©Î¬O¦C¼ÆÅܤ£¦P¡]ªÅ®æ2¦C§ï¬°3¦C¡^ ­n¦p¦ó­×§ï©O

Hsieh

¦^´_ 3# tonycho33

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5", [A65536].End(xlUp).Offset(, 7)).SpecialCells(xlCellTypeConstants) '¦AB:HÄ檺ªº«DªÅ®æ°µ°j°é
   
4.    If IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2) '¦pªG¥¼¥X²{¹L´N¥H¸ÓÀx¦s®æ¤º®e¥[¤J§_«h´N±N­ì¦³¦r¦ê¥H³rÂI³sµ²¸ÓÀx¦s®æ¤º®e
   
5. Next
   
6. For Each a In Range("k5", [K65536].End(xlUp)) '¦bKÄæ©Ò¦³¸ê®Æ°µ°j°é
   
7. ar = Split(d(a.Value), ",")  '±N¥HKÄæÀx¦s®æ¬°ÃöÁä¦rªº¦r¨å¤º®e¥H³rÂI°µ¤À³Î±o¨ì¤@­Ó°}¦C
   
8. a.Offset(, 1).Resize(, UBound(ar) + 1) = ar '±N°}¦C¼g¤JLÄæ¦V¥k
   
9. Next
   
10. End Sub

½Æ»s¥N½X

tonycho33

¦^´_ 4# Hsieh


    ½Ð°Ý¦pªG­ì©l¸ê®Æ¬O¤½¦¡ºâ¥Xªº¡A·|µLªk¨Ï¥Î³o®Mµ{¦¡
¬O§_¥i¸Ñ¨M©O
ÁÂÁÂ

Hsieh

¦^´_ 5# tonycho33

1. Sub nn()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5", [A65536].End(xlUp).Offset(, 7)).SpecialCells(xlCellTypeFormulas) '¦AB:HÄ檺ªº¤½¦¡Àx¦s®æ°µ°j°é
   
4.    If a.Value<>"" And IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2) '¦pªG¥¼¥X²{¹L´N¥H¸ÓÀx¦s®æ¤º®e¥[¤J§_«h´N±N­ì¦³¦r¦ê¥H³rÂI³sµ²¸ÓÀx¦s®æ¤º®e
   
5. Next
   
6. For Each a In Range("k5", [K65536].End(xlUp)) '¦bKÄæ©Ò¦³¸ê®Æ°µ°j°é
   
7. ar = Split(d(a.Value), ",")  '±N¥HKÄæÀx¦s®æ¬°ÃöÁä¦rªº¦r¨å¤º®e¥H³rÂI°µ¤À³Î±o¨ì¤@­Ó°}¦C
   
8. a.Offset(, 1).Resize(, UBound(ar) + 1) = ar '±N°}¦C¼g¤JLÄæ¦V¥k
   
9. Next
   
10. End Sub

½Æ»s¥N½X

tonycho33

½Ð°Ý¤§«e¨Ï¥Î±zªº¤½¦¡«á
§Ú®M¥Î¤§«á·|¥X²{¤@¨Ç­«½Æ©Î¬OªÅ®æ¡]ªþ¥ó¡^
­n¦p¦ó¸Ñ¨M©O

Hsieh

¦^´_ 7# tonycho33

1. Sub nn2()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. For Each a In Range("C5", [O65536].End(xlUp)).SpecialCells(xlCellTypeConstants) '¦bC:OÄ檺ªº«DªÅ®æ°µ°j°é
   
4. If a <> 0 Then
   
5.    If IsEmpty(d(a.Value)) Then d(a.Value) = Cells(a.Row, 2) Else d(a.Value) = d(a.Value) & "," & Cells(a.Row, 2) '¦pªG¥¼¥X²{¹L´N¥H¸ÓÀx¦s®æ¤º®e¥[¤J§_«h´N±N­ì¦³¦r¦ê¥H³rÂI³sµ²¸ÓÀx¦s®æ¤º®e
   
6. End If
   
7. Next
   
8. For Each a In Range("q5", [q65536].End(xlUp)) '¦bKÄæ©Ò¦³¸ê®Æ°µ°j°é
   
9. ar = Split(d(a.Value), ",")  '±N¥HKÄæÀx¦s®æ¬°ÃöÁä¦rªº¦r¨å¤º®e¥H³rÂI°µ¤À³Î±o¨ì¤@­Ó°}¦C
   
10. a.Offset(, 1).Resize(, UBound(ar) + 1) = ar '±N°}¦C¼g¤JLÄæ¦V¥k
    
11. Next
    
12. End Sub

½Æ»s¥N½X

Andy2483

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

°õ¦æ«e:

¤U¸ü (109 KB)

2023-4-12 15:19

°õ¦æµ²ªG:

¤U¸ü (124.59 KB)

2023-4-12 15:20

Option Explicit
Sub TEST()
Dim Brr, Y, i&, j&, N&, T$, T1$, Ma%
Dim xR As Range, Ra As Range, Sh As Worksheet
Set Y = CreateObject("Scripting.Dictionary")
Set Sh = ActiveSheet: [Q:IA].ClearContents
Set xR = Range(Sh.[IA5], Sh.Cells(Rows.Count, "B").End(3))
Brr = xR
For i = 1 To UBound(Brr)
   T1 = Brr(i, 1): If T1 = "" Then GoTo i01
   For j = 2 To 14
      T = Brr(i, j): If T = "" Then GoTo i02
      If InStr(T, "A") Then
         T = Format(Mid(T, 2), "A" & "000")
         If Y(T) = "" Then
            N = N + 1: Brr(N, 16) = T
            Y(T) = N: Y(T & "/c") = 17
            Else
               Y(T & "/c") = Y(T & "/c") + 1
               If Ma < Y(T & "/c") Then Ma = Y(T & "/c")
         End If
         Brr(Y(T), Y(T & "/c")) = T1
      End If
i02:
   Next
i01:
Next
With [B5].Resize(UBound(Brr), Ma + 16)
   .Value = Brr
   With Intersect(.Cells, .Cells.Offset(0, 15))
      .Sort KEY1:=.Item(1), Order1:=1, Header:=2
      For i = 1 To N: .Item(i, 1) = "A" & Val(Mid(.Item(i, 1), 2)): Next
   End With
End With
Set Y = Nothing: Set xR = Nothing: Set Sh = Nothing: Erase Brr
End Sub