[µo°Ý] ¨D§U¶ñ¤J±M®×½s¸¹

xandertco

¤p§Ì¥u·|¼g²³æªºVBA¤Î¿ý»s¥¨¶°,©Ò¥H¨D§U¦U¦ì¥ý¶i, ÁÂÁÂ!

Àɮפº¦³2­Ó¤u§@ªí,¥Í²£»â°h®Æ©ú²Ó¤Î±M®×½s¸¹, »Ý±N±M®×½s¸¹¤u§@ªí¤ºªº±M®×½s¸¹¶ñ¤J¥Í²£»â°h®Æ©ú²Óªí¤º»s¥O³æ¸¹«á­±.

xandertco

ÁÂÁ¦U¦ì¥ý¶iªºÀ°¦£!

stillfish00

¦^´_ 4# Hsieh
¾Ç²ß¤F¡A³o¥N½X¦n¦h¤F¡A
ªº½TÀ³¸ÓºÉ¶q¤Ö¥Î½Æ»s¶K¤W¤ñ¸û¦n¡C

Hsieh

¦^´_ 2# xandertco

1. Sub ¶ñ¤J()
   
2. Set d = CreateObject("Scripting.Dictionary")
   
3. With Sheets("±M®×½s¸¹")
   
4.    ar = .Range("A1").CurrentRegion.Value
   
5.    For i = 2 To UBound(ar, 1)
   
6.       d(ar(i, 1)) = IIf(d(ar(i, 1)) = "", ar(i, 2), d(ar(i, 1)) & "," & ar(i, 2))
   
7.    Next
   
8. End With
   
9. With Sheets("¥Í²£»â°h®Æ©ú²Óªí")
   
10.    For Each a In .Range("A:A").SpecialCells(xlCellTypeConstants)
    
11.    If d(a.Value) <> "" Then
    
12.       ay = Split(d(a.Value), ",")
    
13.        a.Offset(, 16).Resize(, UBound(ay) + 1) = ay
    
14.     End If
    
15.    Next
    
16. End With
    
17. End Sub

½Æ»s¥N½X

stillfish00

¦^´_ 1# xandertco
¸Õ¸Õ§a

1. Sub Test()
   
2.     Dim r1 As Long, r2 As Long
   
3.    
   
4.     Application.ScreenUpdating = False
   
5. 
   
6.     With Sheets("¥Í²£»â°h®Æ©ú²Óªí")
   
7.         r1 = .Cells(.Rows.Count, "A").End(xlUp).Row - 1  '[¦X­p]ªº¤W­±¤@¦C
   
8.         
   
9.         ' A9 ¨ì A680 ¤¤¬°±`¼Æ¤å¦rªºÀx¦s®æ
   
10.         With .Range(.[A9], .Cells(r1, "A")).SpecialCells(xlCellTypeConstants, xlTextValues)
    
11.             For Each x In .Cells
    
12.                 '¹ï«D»s¥O³æ¸¹ªº¦C
    
13.                 If x.Value <> "»s¥O³æ¸¹" Then
    
14.                     With Sheets("±M®×½s¸¹")
    
15.                         .AutoFilterMode = False '¨ú®ø¦Û°Ê¿z¿ï
    
16.                         r2 = .Cells(.Rows.Count, "A").End(xlUp).Row     '¥HAÄæ§ä³Ì¤j¦C¼Æ
    
17.                         .Range("A1:B" & r2).AutoFilter Field:=1, Criteria1:=x.Value     '¥Hx³æ¸¹¥h¿z¿ï
    
18.                         .Range("B2:B" & r2).SpecialCells(xlCellTypeVisible).Copy        '½Æ»sBÄæ¥i¨£Äæ
    
19.                     End With
    
20.                     x.Offset(, 16).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, Transpose:=True   'Âà¸m¶K¤W¨ìQÄæ¥k¤è
    
21.                 End If
    
22.             Next
    
23.         End With
    
24.     End With
    
25.    
    
26.     Application.ScreenUpdating = True
    
27. End Sub

½Æ»s¥N½X

xandertco

¥[¤J±M®×½s¸¹.rar (45.8 KB)

¤U¸ü¦¸¼Æ: 13

2013-6-10 08:29