返回列表 上一主題 發帖

[發問] 重複照片格式貼上Excel

cj044

帖子
3 
主題
2 
精華
0 
積分
5 
點名
0  
作業系統
windws 
軟體版本
7 
閱讀權限
10 
性別
男 
註冊時間
2014-7-28 
最後登錄
2021-6-24 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-7-29 14:57 | 顯示全部帖子

[發問] 重複照片格式貼上Excel

目前有一堆格式相同的文件需要處理

約有1千筆 http://1drv.ms/1pi6g2x


(二. 組立步驟:)文字上方 是來此檔案 http://1drv.ms/1pi7LOe


(二. 組立步驟:) 文字下方 是來自同一資料夾的照片

幾乎模式都一樣 只是檔案不一樣 照片不一樣

要改的只有組立照片右半部文字


另外 目前新增功能 如果中間再插入步驟的話 步驟號碼會自動再跳號不必手動修改!

整個檔案部分內容放置圖一

完整檔案放置在最後一頁

但是寫完VBA 不知道出了甚麼問題 仍然無法使用?

成果是希望如此檔案 http://1drv.ms/1AnLV1s


Sub Ex()
Dim Fs As Object, E, i As Integer, P, ii As Integer
With CreateObject("Scripting.FileSystemObject").GetFolder("d:\相片\") '<-修改
為你要查詢之資料夾假設在d槽
i = 1
For Each E In .SubFolders
If i > ActiveWorkbook.Sheets.Count Then
Sheets.Add(, Sheets(Sheets.Count)).Name = E.Name
Else
Sheets(i).Name = E.Name '<-新檔名取代品名以及舊檔名
End If
ii = 1
For Each P In E.Files
If InStr(UCase(P.Name), ".JPG") Then
With Sheets(i).Pictures.Insert(P)
.Top = Cells(ii, 2).Top
.Left = Cells(ii, 2).Left
.Width = 50
.Height = 50
End With
ii = ii + 5
End If
Next
i = i + 1
Next
Dim St As Worksheet: Set St = ThisWorkbook.Worksheets("Sheet1")
Dim Mx
Workbooks.Open "D:\Book2.xls"假設在檔名為Book2
Mx = Range(St.[A1], St.[C10])
Workbooks("Book2").Sheets("Sheet1").[A1].Resize(UBound(Mx, 1), UBound(Mx, 2))
= Mx
Workbooks("Book2").Close True


End With
End Sub
收藏 分享

cj044

帖子
3 
主題
2 
精華
0 
積分
5 
點名
0  
作業系統
windws 
軟體版本
7 
閱讀權限
10 
性別
男 
註冊時間
2014-7-28 
最後登錄
2021-6-24 
2#
發表於 2014-7-30 14:20 | 顯示全部帖子
目前有一堆格式相同的文件需要處理

約有1千筆 http://1drv.ms/1pi6g2x


(二. 組立步驟文字上方 是 ...
cj044 發表於 2014-7-29 14:57


可能是我描述不清楚

我重新再PO一篇文章!

軟體:Excel

版本:2007

整個原始檔案部分 http://1drv.ms/1lUW4sU

物料表檔案http://1drv.ms/1lUWdMT

規格內容需求http://1drv.ms/1qK0tGD

程式部分

Sub Ex()
Dim Fs As Object, E, i As Integer, P, ii As Integer
With CreateObject("Scripting.FileSystemObject").GetFolder("d:\相片\") '<-修改
為你要查詢之資料夾假設在d槽
i = 1
For Each E In .SubFolders
If i > ActiveWorkbook.Sheets.Count Then
Sheets.Add(, Sheets(Sheets.Count)).Name = E.Name
Else
Sheets(i).Name = E.Name '<-新檔名取代品名以及舊檔名
End If
ii = 1
For Each P In E.Files
If InStr(UCase(P.Name), ".JPG") Then
With Sheets(i).Pictures.Insert(P)
.Top = Cells(ii, 2).Top
.Left = Cells(ii, 2).Left
.Width = 50
.Height = 50
End With
ii = ii + 5
End If
Next
i = i + 1
Next
Dim St As Worksheet: Set St = ThisWorkbook.Worksheets("Sheet1")
Dim Mx
Workbooks.Open "D:\Book2.xls"假設在檔名為Book2
Mx = Range(St.[A1], St.[C10])
Workbooks("Book2").Sheets("Sheet1").[A1].Resize(UBound(Mx, 1), UBound(Mx, 2))
= Mx
Workbooks("Book2").Close True


End With
End Sub

不知道是有bug? 為何無法啟動? 感謝大大解答!

TOP

        靜思自在 : 人的眼睛長在前面，只看到別人的缺點，絲毫看不到自己的缺點。
返回列表 上一主題