返回列表 上一主題 發帖

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

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2013-5-3 18:02 | 只看該作者

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

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

  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]

question.zip (484.97 KB)

收藏 分享

Hsieh

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

2023年全勤獎章2022虎年全勤獎章2021牛年全勤獎章2020鼠年全勤獎章2019 豬年全勤獎章2018 狗年全勤獎章2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱心公益勳章2011兔年全勤獎章
2#
發表於 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
複製代碼
學海無涯_不恥下問

TOP

cmo140497

帖子
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 版主您早 :
有一小問題,不知這巨集是哪裡出錯,再麻煩您解決小弟的疑惑,感恩!

TOP

cmo140497

帖子
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.連同圖片,一起複製相鄰之空白欄位
再麻煩版主解決小弟的疑惑,謝謝您!

TOP

cmo140497

帖子
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)
,就可以了,不好意思,感謝版主的指導

TOP

GBKEE

帖子
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
直接複製
  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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

cmo140497

帖子
95 
主題
29 
精華
0 
積分
150 
點名
0  
作業系統
windows2003 
軟體版本
office 2003 
閱讀權限
20 
性別
男 
來自
Kaoshiung 
註冊時間
2010-11-5 
最後登錄
2018-2-8 
7#
發表於 2013-5-6 15:25 | 只看該作者
回復 6# GBKEE


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

TOP

        靜思自在 : 能幹不幹，不如苦幹實幹。
返回列表 上一主題