baconbacons

以下程式碼目的是要將特定資料夾中的相片插入到指定儲存格並依儲存格大小調整相片尺寸
目前問題出在於「Set  picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))」
上述程式作用是依序於儲存格「A5,A29,A54,A78,A103,A127…」輸入相片流水號「1,2,3,4,5,6…」
執行後會出現執行階段錯誤「應用程式或物件定義上的錯誤」
監看了「Range(…) 」發現並不會呈現A5 所以也沒辦法指定給picNumRng
細看了一下 (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0))的結果確實是可以算出我需要的格數
但是與 Range("A" …)  無法結合成我需要的A5 是何原因？
--------------------------------------------------------------------------------------------
Sub photoConv()
    Dim myFSO As New FileSystemObject
    Dim myPath As String, myPic As Object
    Dim E As Range, picNumRng As Object
    Dim myPhoto As String, countPhoto As String
    Dim i As Integer, j As Integer, k As Integer

    myPath = ThisWorkbook.Path                                                                                            '確認活頁簿所在路徑
    myPhoto = Dir(myPath & "\" & "原始相片" & "\" & "*.jpg")
    countPhoto = myFSO.GetFolder(myPath & "\" & "原始相片").Files.Count - 1    '取得相片數量
    If myPhoto <> "" Then                                                                                                           '資料夾中有相片時複製表格
        j = 50
        For i = 1 To ((countPhoto + 1) \ 2 - 1)
            Rows("1:49").Copy                                                                                                           '複製表格
            ActiveSheet.Paste Cells(j, 1)
            j = j + 49
        Next i
        
        For k = 1 To countPhoto                                                                                                   '輸入相片編號
            Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
            picNumRng = k
                For Each E In picNumRng                                                                                          '逐一處理儲存格
                    Set myPic = ActiveSheet.Pictures.Insert(myPath & E & ".jpg")                '插入與儲存格同名的相片檔
                        With myPic
                            .ShapeRange.LockAspectRatio = msoFalse
                            .Left = E.Cells(1, 2).Left
                            .Top = E.Cells(1, 2).Top
                            .Width = E.Cells(1, 2).Width
                            .Height = E.Cells(1, 2).Height
                        End With
                Next
        Next
    Else
        MsgBox "資料夾中沒有相片"
    End If
End Sub

GBKEE

回復 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

複製代碼

baconbacons

回復 2# GBKEE
GBKEE 大：
                     原先的程式碼本來在輸入編號就沒問題 只是在插入相片時會有錯誤產生
                     我將原始的程式碼改成你建議的方式 還是出現一樣的錯誤問題
                     還能怎麼修改呢？

GBKEE

回復 3# baconbacons
我的2003版可以的需請有2010版的相助.

baconbacons

回復 4# GBKEE
請教 GBKEE 大：
你所謂的2003可以是指可以輸入流水編號，還是說連插入圖片也可以？
因為我執行你建議程式碼 只有選取符合的儲存格 最後停在k=50的那個儲存格

另外請教一個 For Each... Next 的觀念問題？
是否這個用法只針對「未運算執行巨集程式前」之「符合條件的所有物件集合」？
換言之 就是以我自己的這個例子來說
Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
我的物件集合picNumRng是在For Next迴圈執行之後 才會「逐一」運算產生符合的物件
而不是在運算之前就已經完全得知所有的物件
在運用此種逐一產生的物件是否就必須再搭配For Next用法  而不是 For Each... Next
不知道這樣表達夠不夠清楚

c_c_lai

回復 5# baconbacons
試試這個：

1. Sub Ex2()
   
2.     Dim myFSO As New FileSystemObject
   
3.     Dim myPath As String, myPic As Object
   
4.     Dim myPhoto As String, countPhoto As Long       '  countPhoto As String
   
5.     Dim picNumRng As Object
   
6.     Dim k As Integer
   
7. 
   
8.     myPath = ThisWorkbook.Path                                                                                            '  確認活頁簿所在路徑
   
9.     countPhoto = myFSO.GetFolder(myPath & "\" & "原始相片").Files.Count          '  取得相片數量
   
10.     myPhoto = Dir(myPath & "\" & "原始相片" & "\" & "*.jpg")
    
11.    
    
12.     If myPhoto <> "" Then                                                                                                           '  資料夾中有相片時複製表格
    
13.         For k = 1 To countPhoto                                                                                                   '  輸入相片編號
    
14.             Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
    
15.             
    
16.             ActiveSheet.Pictures.Insert (myPath & "\" & "原始相片" & "\" & myPhoto)              '  插入與儲存格同名的相片檔
    
17.             With ActiveSheet.Shapes(k)
    
18.                 .LockAspectRatio = msoFalse
    
19.                 .Top = picNumRng.Top
    
20.                 .Left = picNumRng.Left
    
21.                 .Width = 75
    
22.                 .Height = 100
    
23.             End With
    
24.             myPhoto = Dir
    
25.         Next
    
26.     Else
    
27.         MsgBox "資料夾中沒有相片"
    
28.     End If
    
29. End Sub

複製代碼

GBKEE

回復 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

複製代碼

baconbacons

回復 6# c_c_lai
c_c_lai 大：
經過修改後測試 確實可以執行 但是因為使用「ActiveSheet.Shapes(k)」的用法的關係
由於我在活頁中也設計了一個執行按鈕 所以這個用法會去抓這個按鈕的圖示 再貼到我指定儲存格
（如果沒有設計該按鈕的話 您所建議的程式碼確實都是可以符合我的需求的）
這個部分我比不知道怎麼改善 所以就試著使用GBKEE大的建議方法
不過 還是感謝c_c_lai 大的協助 讓我學到 .Shapes(k) 以及 myPhoto = Dir  的用法
感激…

baconbacons

回復 7# GBKEE
GBKEE 大：
感謝清楚的範例解決我的觀念問題  我也利用這個小例子改善我原先的程式碼
確實已經可以執行了 萬分感謝
以下也貼上我修改後的程式碼  讓有需要的人也可以學習
如果能讓程式碼更簡潔的話 也請其他大大指教
----------------------------------------------------------------------------------------------
Sub photoConv1()
    Dim myFSO As New FileSystemObject
    Dim myPath As String
    Dim picNumRng As Range, myPic As Object
    Dim myPhoto As String, countPhoto As String
    Dim E As Variant
    Dim i As Integer, j As Integer, k As Integer
   
    myPath = ThisWorkbook.Path                                                                                                          '確認活頁簿所在路徑
    myPhoto = Dir(myPath & "\" & "原始相片" & "\" & "*.jpg")                                                    '圖片檔路徑
    countPhoto = myFSO.GetFolder(myPath & "\" & "原始相片").Files.Count - 1                  '取得相片數量
    If myPhoto <> "" Then                                                                                                                         '資料夾中有相片時複製表格
        j = 50
        ActiveSheet.Cells(27, 3).Value = ActiveSheet.Cells(3, 3).Value
        ActiveSheet.Cells(28, 7).Value = ActiveSheet.Cells(4, 7).Value
        ActiveSheet.Cells(27, 7).Value = ActiveSheet.Cells(3, 7).Value
        ActiveSheet.Cells(27, 8).Value = ActiveSheet.Cells(3, 8).Value
        ActiveSheet.Cells(27, 10).Value = ActiveSheet.Cells(3, 10).Value
        ActiveSheet.Cells(27, 12).Value = ActiveSheet.Cells(3, 12).Value
        ActiveSheet.Cells(27, 14).Value = ActiveSheet.Cells(3, 14).Value
        
        For i = 1 To ((countPhoto + 1) \ 2 - 1)
            Rows("1:49").Copy                                                                                                                          '複製表格
            ActiveSheet.Paste Cells(j, 1)
            j = j + 49
        Next i
        
        For k = 1 To countPhoto
            Set picNumRng = Range("A" & (25 * (k - 1) + 5 - Application.WorksheetFunction.RoundUp((k - 1) / 2, 0)))
                picNumRng = k                                                                                                                            '輸入相片編號
                For Each E In picNumRng
                Set myPic = ActiveSheet.Pictures.Insert(myPath & "\" & "原始相片" & "\" & E & ".jpg")   '插入與儲存格同名的相片檔
                With myPic
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Top = picNumRng.Offset(0, 1).Top
                    .Left = picNumRng.Offset(0, 1).Left
                    .Width = picNumRng.Offset(0, 1).MergeArea.Width
                    .Height = picNumRng.Offset(0, 1).MergeArea.Height
                End With
                Next
        Next k
    Else
        MsgBox "資料夾中沒有相片"
    End If
    Set picNumRng = Nothing
    Set myPic = Nothing
End Sub

GBKEE

回復 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

複製代碼