請教版主及各位大大們,如何使用autofilter 連同照片也copy至目的地

cmo140497

Dear 各位版主及大大們您好 :
小弟有一問題,如何使用autofilter or advancedfilter 在於特定條件篩選後作複制的動作,連同欄位大小及儲存格內之照片
已設定圖片屬性為大小位置隨儲存格改變,也有使用pastesAll,也均不得其解,再麻煩各位可以解決小弟的疑惑,感恩!

下載 (143.57 KB)

2013-5-3 18:00

1. Sub test()
   
2. Dim mytbl As Range
   
3. [a1].CurrentRegion.ClearContents
   
4. Set mytbl = [a1].End(xlToRight).CurrentRegion
   
5. Set myQry = [a1]
   
6. mytbl.Columns(4).AdvancedFilter xlFilterCopy, copytorange:=myQry, unique:=True
   
7. Set myQry = myQry.CurrentRegion
   
8. For i = 2 To myQry.Rows.Count
   
9.     x = [aa2].End(xlToLeft).Column + 1
   
10.     With mytbl
    
11.         .AutoFilter 4, myQry.Rows(i)
    
12.         .Copy
    
13.         Cells(1, x).PasteSpecial xlPasteColumnWidths
    
14.         Cells(1, x).PasteSpecial xlPasteAll
    
15.         mytbl.AutoFilter
    
16.     End With
    
17. Next
    
18. End Sub

複製代碼

[attach]14880[/attach]

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

複製代碼

cmo140497

回復 2# Hsieh


    Dear 版主您早 :
有一小問題,不知這巨集是哪裡出錯,再麻煩您解決小弟的疑惑,感恩!

下載 (206.16 KB)

2013-5-6 08:22

cmo140497

回復 2# Hsieh


    不好意思,小弟沒有解釋的很清楚,小弟用I欄位作為篩選條件,先篩選出不重複之no.值於A欄位,再將A欄位依序當Criteria,再篩選將相同之no.連同圖片,一起複製相鄰之空白欄位
再麻煩版主解決小弟的疑惑,謝謝您!

下載 (49.31 KB)

2013-5-6 08:35

cmo140497

回復 3# cmo140497


    歹勢,找到問題了,A欄位,版主以為CRITERIA是原有的,小弟加了進去,另外Pictures,小弟改成ActiveSheet.Pictures(pic.Name)
,就可以了,不好意思,感謝版主的指導

GBKEE

回復 5# cmo140497
直接複製

1. Option Explicit
   
2. Sub Ex()
   
3.     Dim mytbl As Range, myQry As Range, P As Pictures, I As Integer
   
4.     Application.ScreenUpdating = False
   
5.     With Sheets("工作表1")
   
6.         .Activate
   
7.         .[a1].CurrentRegion.ClearContents
   
8.         .Range("J1", .[J1].End(xlToRight)).EntireColumn.Clear  '清除舊有資料 (Clear 無法刪除圖片)
   
9.         Set P = .Pictures                                      '圖片集合
   
10.         For I = P.Count To 1 Step -1
    
11.             If Intersect(.Range(P(I).TopLeftCell.Address), .[F:F]) Is Nothing Then '圖片位置不在 F欄
    
12.                 P(I).Delete                                    '圖片 刪除
    
13.             End If
    
14.         Next
    
15.         Set mytbl = .[F:I]
    
16.         Set myQry = .[a1]
    
17.         mytbl.Columns(4).AdvancedFilter xlFilterCopy, copytorange:=myQry, unique:=True
    
18.         Set myQry = myQry.CurrentRegion
    
19.         For I = 2 To myQry.Rows.Count
    
20.             With mytbl
    
21.                 .AutoFilter 4, myQry.Rows(I)
    
22.                 .SpecialCells(xlCellTypeVisible).Copy
    
23.                 .Parent.Cells(1, .Parent.Columns.Count).End(xlToLeft).Offset(, 1).Select
    
24.                 .Parent.Paste
    
25.                 'ActiveSheet.Paste
    
26.             End With
    
27.         Next
    
28.     End With
    
29.     mytbl.AutoFilter
    
30.     myQry.Select
    
31.     Application.ScreenUpdating = True
    
32. End Sub

複製代碼

cmo140497

回復 6# GBKEE


    感謝版主的指導,小弟又學了新的方法,感恩!