ªð¦^¦Cªí ¤W¤@¥DÃD µo©«

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

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

½Ð°Ý¤@¤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

±Æ§Ç.rar (4.33 KB)

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 2# Hsieh


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

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

¦^´_ 4# Hsieh


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

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

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

±Æ§Ç11.rar (12.33 KB)

TOP

¦^´_ 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
¾Ç®üµL²P_¤£®¢¤U°Ý

TOP

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

°õ¦æ«e:


°õ¦æµ²ªG:



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
¥Î¦æ°Ê¸Ë¸mÂsÄý½×¾Â¾Ç²ß«Ü¤è«K,ÁÂÁ½׾¸gÀç¹Î¶¤
½Ð¤j®a¤@°_¤W½×¾Â¨Ó¥æ¬y

TOP

        ÀR«ä¦Û¦b : ¤Hªº²´·úªø¦b«e­±¡A¥u¬Ý¨ì§O¤Hªº¯ÊÂI¡Aµ·²@¬Ý¤£¨ì¦Û¤vªº¯ÊÂI¡C
ªð¦^¦Cªí ¤W¤@¥DÃD