返回列表 上一主題 發帖

[發問] 新手發問有關活頁中的圖片操作

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
1# 跳轉到 »
發表於 2014-4-3 20:50 | 顯示全部帖子
回復 1# baconbacons
2003版可以的
  1. Option Explicit
  2. Sub ex()
  3.     Dim k, picNumRng As Range
  4.     For k = 1 To 50 'countPhoto                       '輸入相片編號
  5.         Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
  6.         picNumRng.Select            
  7.     Next
  8. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2014-4-7 15:35 | 顯示全部帖子
回復 3# baconbacons
我的2003版可以的需請有2010版的相助.
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
3#
發表於 2014-4-7 21:12 | 顯示全部帖子
回復 5# baconbacons
  1. Option Explicit
  2. Sub Ex()
  3.     Dim E As Variant, K As Integer, picNumRng As Range
  4.     For Each E In Workbooks     'Workbook物件 的集合物件
  5.         MsgBox E.Name
  6.     Next
  7.     For Each E In Range("A5:C5") 'Cells物件 的集合物件
  8.         MsgBox E.Address
  9.     Next
  10.     For K = 1 To 50     '跑50次迴圈
  11.         Set picNumRng = Range("A" & (25 * (K - 1) + 5 - Application.WorksheetFunction.RoundUp((K - 1) / 2, 0)))
  12.         For Each E In picNumRng 'Cells物件 的集合物件
  13.             MsgBox E.Address
  14.         Next
  15.     Next
  16. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
4#
發表於 2014-4-8 06:24 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-4-8 06:27 編輯

回復 9# baconbacons
Dim myFSO As New FileSystemObject
需設定 引用項目  Microsoft scripting runtime
  1. Option Explicit
  2. Sub Ex()
  3.     Dim myFSO As New FileSystemObject
  4.     Dim picNumRng As Range
  5.     Dim E As Variant, k As Integer, P As Object               
  6.     With ActiveSheet        '指定工作表
  7.         .Pictures.Delete    '刪除 所有相片
  8.         For Each P In myFSO.GetFolder("d:\相片\74年").Files         '檔案物件集合
  9.             If UCase(P) Like "*.JPG" Then    'P 檔案物件 傳回完整路徑名稱 , Like 比對是否有".JPG"的字元
  10.                 k = k + 1
  11.                 Set picNumRng = .Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
  12.                 With picNumRng
  13.                     .Rows("1:1").RowHeight = 100                   '調整 高度
  14.                     .Columns("A:A").ColumnWidth = 25               '調整 寬度
  15.                 End With
  16.                 With .Pictures.Insert(P)                           '插入 P 檔案物件(相片)
  17.                     .ShapeRange.LockAspectRatio = msoFalse
  18.                     .Top = picNumRng.Top
  19.                     .Left = picNumRng.Left
  20.                     .Width = picNumRng.Width
  21.                     .Height = picNumRng.Height
  22.                 End With
  23.             End If
  24.         Next
  25.     End With
  26.     MsgBox "資料夾中" & IIf(k > 0, "共" & k & "張", "沒有") & "相片"
  27. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2014-4-8 18:06 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-4-8 20:04 編輯

回復 11# baconbacons
  1. Option Explicit
  2. Sub Ex()
  3.     Dim i, countPhoto, Rng As Range
  4.     countPhoto = 50
  5.     Set Rng = Rows("1:49")
  6.     For i = Rng.Rows.Count To (countPhoto + 1) * Rng.Rows.Count + 1 Step Rng.Rows.Count '間隔 Rng的列數=49
  7.         Rng.Copy                        '複製表格
  8.         With ActiveSheet.Cells(i + 1, 1)
  9.         'With 陳述式 在一個單一物件或一個使用者自訂型態上執行一系列的陳述式。
  10.         '加上 . 為這單一物件的屬性或方法
  11.             .PasteSpecial Paste:=xlPasteFormats                     '這單一物件:  僅貼上格式
  12.             .Resize(Rng.Rows.Count, Rng.Columns.Count) = Rng.Value   '這單一物件:  貼上數值
  13.         End With
  14.     Next
  15. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

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#
發表於 2014-4-9 17:53 | 顯示全部帖子
回復 1# baconbacons

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

TOP

GBKEE

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

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2014-4-10 14:18 | 顯示全部帖子
本帖最後由 GBKEE 於 2014-4-10 16:09 編輯

回復 16# baconbacons

由於表格是複製編號1及編號2的表格而來 所以每次新增相片會多出兩個空白相片儲存格
Q:為何一次要,複製編號1及編號2的表格

1.假設新增插入編號11的相片，刪除原先編號11之後的相片及表格，重新複製所需表格，新增編號11相片再讀入資料夾的相片自編號12開始貼
Q: 新增插入編號11的相片,為何是:刪除原先編號11之後的相片及表格,而不包含原先編號11相片及表格,
    為何是:自編號12開始貼,不是自編號11開始貼

2.假設新增插入編號11的相片，複製新表格（2空白相片儲存格）插入，新增編號11相片再將活頁中的相片依序往上遞補1張
Q:為何要: 複製新表格（2空白相片儲存格）插入,多一空白位置爾後將相片依序往上遞補1張(多此一舉)

是這樣嗎?
  1. Sub Ex()
  2.     Dim myFSO As New FileSystemObject
  3.     Dim Rng As Range, i As Integer
  4.     Dim myPath As String
  5.     Dim E As Variant
  6.     myPath = ThisWorkbook.Path & "\原始相片"            '相片的資料夾
  7.     If myFSO.GetFolder(myPath).Files.Count > 0 Then     '有檔案
  8.         With ActiveSheet                                '指定工作表
  9.             .Pictures.Delete                            '刪除所有相片
  10.             Set Rng = .[A3:O25]                         '相片表格
  11.             .Rows("26:" & .UsedRange.Rows.Count).Clear   '清除 第一張相片以後的表格
  12.             For Each E In myFSO.GetFolder(myPath).Files '檔案物件集合
  13.                 If UCase(E) Like "*.JPG" Then           'E (檔案物件)傳回完整路徑名稱 , Like 比對是否有".JPG"的字元
  14.                     With Rng.Offset((i) * Rng.Rows.Count + (i * 1)) '相片的表格位置
  15.                         If i > 0 Then                    '第2張後
  16.                             Rng.Copy
  17.                             .PasteSpecial xlPasteFormats
  18.                             .Value = Rng.Value
  19.                             .Range("A3") = i + 1         '相片的表格位置的Range("A3")
  20.                         End If
  21.                         .Range("C22") = E
  22.                         .Range("B3").Select              '相片的表格位置的Range("B3")
  23.                     End With
  24.                     With .Pictures.Insert(E)                                      '插入P檔案物件(相片)
  25.                         .ShapeRange.LockAspectRatio = msoFalse
  26.                         .Top = Selection(1, 1).Top
  27.                         .Left = Selection(1, 1).Left
  28.                         .Width = Selection.Width
  29.                         .Height = Selection.Height
  30.                     End With
  31.                     i = i + 1
  32.                 End If
  33.             Next
  34.         End With
  35.     End If
  36.     MsgBox myPath & " 資料夾中" & IIf(i > 0, "共" & i & "張", "沒有") & "相片"
  37. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

        靜思自在 : 有智慧才能分辨善惡邪正；有謙虛才能建立美滿人生。
返回列表 上一主題