Hsieh

¦^´_ 1# cmo140497

1. Sub ex()
   
2. Set dic = CreateObject("Scripting.Dictionary")
   
3. Dim MyQtb As Range, VRng As Range
   
4. Set MyQtb = Range("A1").End(xlToRight).CurrentRegion
   
5. Application.ScreenUpdating = False
   
6. For Each pic In ActiveSheet.Pictures
   
7.    Set a = pic.TopLeftCell.Offset(, 1)
   
8.    m = a & a.Offset(, 1)
   
9.    Set dic(a & a.Offset(, 1)) = Pictures(pic.Name)
   
10. Next
    
11. For Each a In Range([A2], [A2].End(xlDown))
    
12.    With MyQtb
    
13.      .AutoFilter 4, a
    
14.      Set Rng = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
    
15.      Set VRng = .SpecialCells(xlCellTypeVisible)
    
16.      VRng.Copy
    
17.      Rng.PasteSpecial xlPasteColumnWidths
    
18.      Rng.PasteSpecial Paste:=xlPasteValues
    
19.      .AutoFilter
    
20.      r = 1
    
21.      Do Until r > Rng.Offset(, 1).End(xlDown).Row - 1
    
22.      Set c = Rng.Offset(r, 0)
    
23.      dic(c.Offset(, 1) & c.Offset(, 2)).Copy
    
24.      c.Select
    
25.      ActiveSheet.Paste
    
26.      r = r + 1
    
27.      Loop
    
28.    End With
    
29. Next
    
30. Application.ScreenUpdating = True
    
31. End Sub

½Æ»s¥N½X