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

帖子: 95
主題: 29
精華: 0
積分: 150
點名: 0
作業系統: windows2003
軟體版本: office 2003
閱讀權限: 20
性別: 男
來自: Kaoshiung
註冊時間: 2010-11-5
最後登錄: 2018-2-8

7^#

發表於 2013-5-6 15:25 | 只看該作者

回復 6# GBKEE

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

GBKEE

超級版主 Rank: 8 Rank: 8

帖子: 5923
主題: 13
精華: 1
積分: 5986
點名: 0
作業系統: win10
軟體版本: Office 2010
閱讀權限: 150
性別: 男
來自: 台灣基隆
註冊時間: 2010-5-1
最後登錄: 2022-1-23

2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章 2011兔年全勤獎章

6^#

發表於 2013-5-6 10:49 | 只看該作者

回復 5# cmo140497
直接複製

Option Explicit
Sub Ex()
Dim mytbl As Range, myQry As Range, P As Pictures, I As Integer
Application.ScreenUpdating = False
With Sheets("工作表1")
.Activate
.[a1].CurrentRegion.ClearContents
.Range("J1", .[J1].End(xlToRight)).EntireColumn.Clear '清除舊有資料 (Clear 無法刪除圖片)
Set P = .Pictures '圖片集合
For I = P.Count To 1 Step -1
If Intersect(.Range(P(I).TopLeftCell.Address), .[F:F]) Is Nothing Then '圖片位置不在 F欄
P(I).Delete '圖片刪除
End If
Next
Set mytbl = .[F:I]
Set myQry = .[a1]
mytbl.Columns(4).AdvancedFilter xlFilterCopy, copytorange:=myQry, unique:=True
Set myQry = myQry.CurrentRegion
For I = 2 To myQry.Rows.Count
With mytbl
.AutoFilter 4, myQry.Rows(I)
.SpecialCells(xlCellTypeVisible).Copy
.Parent.Cells(1, .Parent.Columns.Count).End(xlToLeft).Offset(, 1).Select
.Parent.Paste
'ActiveSheet.Paste
End With
Next
End With
mytbl.AutoFilter
myQry.Select
Application.ScreenUpdating = True
End Sub

複製代碼

感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限, 一天1元的贊助,人人有能力.

帖子: 95
主題: 29
精華: 0
積分: 150
點名: 0
作業系統: windows2003
軟體版本: office 2003
閱讀權限: 20
性別: 男
來自: Kaoshiung
註冊時間: 2010-11-5
最後登錄: 2018-2-8

5^#

發表於 2013-5-6 08:49 | 只看該作者

回復 3# cmo140497

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

帖子: 95
主題: 29
精華: 0
積分: 150
點名: 0
作業系統: windows2003
軟體版本: office 2003
閱讀權限: 20
性別: 男
來自: Kaoshiung
註冊時間: 2010-11-5
最後登錄: 2018-2-8

4^#

發表於 2013-5-6 08:36 | 只看該作者

回復 2# Hsieh

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

帖子: 95
主題: 29
精華: 0
積分: 150
點名: 0
作業系統: windows2003
軟體版本: office 2003
閱讀權限: 20
性別: 男
來自: Kaoshiung
註冊時間: 2010-11-5
最後登錄: 2018-2-8

3^#

發表於 2013-5-6 08:22 | 只看該作者

回復 2# Hsieh

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

Hsieh

超級版主 Rank: 8 Rank: 8

帖子: 4901
主題: 44
精華: 24
積分: 4916
點名: 255
作業系統: Windows 7
軟體版本: Office 20xx
閱讀權限: 150
性別: 男
來自: 台北
註冊時間: 2010-4-30
最後登錄: 2024-11-25

2023年全勤獎章 2022虎年全勤獎章 2021牛年全勤獎章 2020鼠年全勤獎章 2019 豬年全勤獎章 2018 狗年全勤獎章 2017 雞年全勤獎章 2016猴年全勤獎章 2015羊年全勤獎章 2014馬年全勤獎章 2013蛇年全勤獎章 2012龍年全勤獎章論壇貢獻勳章熱心公益勳章 2011兔年全勤獎章

2^#

發表於 2013-5-3 19:49 | 只看該作者

回復 1# cmo140497

Sub ex()
Set dic = CreateObject("Scripting.Dictionary")
Dim MyQtb As Range, VRng As Range
Set MyQtb = Range("A1").End(xlToRight).CurrentRegion
Application.ScreenUpdating = False
For Each pic In ActiveSheet.Pictures
Set a = pic.TopLeftCell.Offset(, 1)
m = a & a.Offset(, 1)
Set dic(a & a.Offset(, 1)) = Pictures(pic.Name)
Next
For Each a In Range([A2], [A2].End(xlDown))
With MyQtb
.AutoFilter 4, a
Set Rng = Cells(1, Columns.Count).End(xlToLeft).Offset(, 1)
Set VRng = .SpecialCells(xlCellTypeVisible)
VRng.Copy
Rng.PasteSpecial xlPasteColumnWidths
Rng.PasteSpecial Paste:=xlPasteValues
.AutoFilter
r = 1
Do Until r > Rng.Offset(, 1).End(xlDown).Row - 1
Set c = Rng.Offset(r, 0)
dic(c.Offset(, 1) & c.Offset(, 2)).Copy
c.Select
ActiveSheet.Paste
r = r + 1
Loop
End With
Next
Application.ScreenUpdating = True
End Sub

複製代碼

學海無涯_不恥下問