Board logo

標題: 請教版主及各位大大們,如何使用autofilter 連同照片也copy至目的地 [打印本頁]
作者: cmo140497    時間: 2013-5-3 18:02     標題: 請教版主及各位大大們,如何使用autofilter 連同照片也copy至目的地

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

[attach]14881[/attach]
  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    時間: 2013-5-3 19:49

回復 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    時間: 2013-5-6 08:22

回復 2# Hsieh


    Dear 版主您早 :
有一小問題,不知這巨集是哪裡出錯,再麻煩您解決小弟的疑惑,感恩!
[attach]14898[/attach]
作者: cmo140497    時間: 2013-5-6 08:36

回復 2# Hsieh


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


[attach]14899[/attach]
作者: cmo140497    時間: 2013-5-6 08:49

回復 3# cmo140497


    歹勢,找到問題了,A欄位,版主以為CRITERIA是原有的,小弟加了進去,另外Pictures,小弟改成ActiveSheet.Pictures(pic.Name)
,就可以了,不好意思,感謝版主的指導
作者: GBKEE    時間: 2013-5-6 10:49

回復 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    時間: 2013-5-6 15:25

回復 6# GBKEE


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



歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)