麻辣家族討論版版 - Powered by Discuz! Board

標題: [發問] 如何將file夾圖檔一次全部帶入excel表格裡 [打印本頁]

作者: jaga0828 時間: 2014-5-29 21:32 標題: 如何將圖片檔匯入EXCEL制定格式內

假設我有一個File裡有20張圖檔或者更多~
然後我在excel裡設定20個或更多的制式表格~
我要如何寫小巨集或其他方式，就可以自動將file的圖片檔匯入這個制式表格裡
有哪位高高手可以幫我解答一下?非常的感謝!

作者: jaga0828 時間: 2014-5-30 22:28

請各位高高手幫忙小弟一下阿~!!!
感謝~

作者: jaga0828 時間: 2014-5-30 23:16

小弟有找到一篇舊文章，但這篇文章的程式碼主要是將照片放在同一欄，名稱在另外一欄
小弟將所需的圖片檔案都放置 D:/TEST 裡面
按巨集=>圖片依序貼上B欄的儲存格然後 C欄依序顯示出檔名
但小弟想請教大家要改為=>圖片依序在A1欄名稱 ->B1欄圖片->C1攔名稱->D1欄圖片然後在排回A2欄名稱 ->B2欄圖片->C2攔名稱->D2欄圖片 ...........
請問各位高手依照下面程式碼可以改為我上面的需求?
感謝大家~

Sub PHOTO()
ActiveSheet.Columns("C") = ""
Set Sh = ActiveSheet
With Sh
.Pictures.Delete
End With
fs = Dir("D:\TEST\*.jpg")
Do Until fs = ""
R = R + 1
Cells(R, 3) = fs
Cells(R, 2).Select
ActiveSheet.Pictures.Insert("D:\TEST\" & Cells(R, 3)).Select
With Selection
.Top = ActiveSheet.Cells(R, 2).Top + 1
.Left = ActiveSheet.Cells(R, 2).Left + 1
.Width = ActiveSheet.Cells(R, 2).Width - 1
.Height = ActiveSheet.Cells(R, 2).Height - 1
End With
fs = Dir
Loop
End Sub

複製代碼

作者: jaga0828 時間: 2014-5-31 23:08 標題: 如何將file夾圖檔一次全部帶入excel表格裡

小弟有找到一篇舊文章，但這篇文章的程式碼主要是將照片放在同一欄，名稱在另外一欄
小弟將所需的圖片檔案都放置 D:/TEST 裡面
按巨集=>圖片依序貼上B欄的儲存格然後 C欄依序顯示出檔名
但小弟想請教大家要改為=>圖片依序在A1欄名稱 ->B1欄圖片->C1攔名稱->D1欄圖片然後在排回A2欄名稱 ->B2欄圖片->C2攔名稱->D2欄圖片 ...........
請問各位高手依照下面程式碼可以改為我上面的需求?
感謝大家~

Sub PHOTO()
ActiveSheet.Columns("C") = ""
Set Sh = ActiveSheet
With Sh
.Pictures.Delete
End With
fs = Dir("D:\TEST\*.jpg")
Do Until fs = ""
R = R + 1
Cells(R, 3) = fs
Cells(R, 2).Select
ActiveSheet.Pictures.Insert("D:\TEST\" & Cells(R, 3)).Select
With Selection
.Top = ActiveSheet.Cells(R, 2).Top + 1
.Left = ActiveSheet.Cells(R, 2).Left + 1
.Width = ActiveSheet.Cells(R, 2).Width - 1
.Height = ActiveSheet.Cells(R, 2).Height - 1
End With
fs = Dir
Loop
End Sub

複製代碼

作者: GBKEE 時間: 2014-6-1 07:01

本帖最後由 GBKEE 於 2014-6-1 20:28 編輯

回復 4# jaga0828
試試看

Option Explicit
Sub Ex()
Dim AR(), i As Integer, ii As Integer, fs As String, Rng As Range
With ActiveSheet
.Cells = ""
.Pictures.Delete
fs = Dir("D:\test\*.jpg")
Do Until fs = ""
ReDim Preserve AR(0 To i)
AR(i) = fs '圖片名稱置入陣列
fs = Dir
i = i + 1
Loop
For i = 0 To UBound(AR) Step 2
For ii = 0 To 1
If ii + i <= UBound(AR) Then
.Cells(Int(i / 2) + 1, 1 + (ii * 2)) = AR(ii + i)
Set Rng = .Cells(Int(i / 2) + 1, 2 + (ii * 2))
With .Pictures.Insert("D:\test\" & AR(ii + i))
.Top = Rng.Top
.Left = Rng.Left
.Width = Rng.Width
.Height = Rng.Height
End With
End If
Next
Next
End With
End Sub

複製代碼

Sub Ex_1()
Dim f As Object, E As Object, Rng As Range, i As Integer
Set f = CreateObject("Scripting.FileSystemObject").getfolder("D:\test").Files
With ActiveSheet
.Cells = ""
.Pictures.Delete
i = 1
For Each E In f
If LCase(E) Like "*.jpg" Then
If i Mod 2 > 0 Then
Set Rng = .Cells(Int(i / 2) + 1, 1)
Else
Set Rng = .Cells(i - Int(i / 2), 3)
End If
Rng.Value = E
With .Pictures.Insert(E)
.Top = Rng.Cells(1, 2).Top
.Left = Rng.Cells(1, 2).Left
.Width = Rng.Cells(1, 2).Width
.Height = Rng.Cells(1, 2).Height
End With
i = i + 1
End If
Next
End With
End Sub

複製代碼

作者: jaga0828 時間: 2014-6-1 13:48

感謝GBKEE大大的幫忙! 這裡高手真的很厲害，祝端午佳節愉快~

作者: justinbaba 時間: 2014-10-31 16:15

GBKEE大大您好~~
好像第二段的執行時會跳出無法取得 Pic 的 insert 屬性？
不知怎麼解決呢？

作者: justinbaba 時間: 2014-10-31 16:54

GBKEE  大..

我發現到  原來原PO 的第三帖就是接近我想要的功能了..
因為我平常用的就是類似這樣..

只是想要知道的是否有辦法再增進為

1、可秀出中文檔名

2、該資料夾的圖檔都一次PO上  (這個範例我剛試過.. 不知為何就是無法把 D:\Test 中的全部都丟入 ?? )

3、圖檔屬性自動變為 "大小位置隨儲存格而變"
因為這部份如果忘記改的話~~執行了篩選功能後，圖跟原本右方相對應的數值、文字會錯亂
是否有更方便的方式能解決呢？

Sub PHOTO()
ActiveSheet.Columns("C") = ""
Set Sh = ActiveSheet
With Sh
.Pictures.Delete
End With
fs = Dir("D:\TEST\*.jpg")
Do Until fs = ""
R = R + 1
Cells(R, 3) = fs
Cells(R, 2).Select
ActiveSheet.Pictures.Insert("D:\TEST\" & Cells(R, 3)).Select
With Selection
.Top = ActiveSheet.Cells(R, 2).Top + 1
.Left = ActiveSheet.Cells(R, 2).Left + 1
.Width = ActiveSheet.Cells(R, 2).Width - 1
.Height = ActiveSheet.Cells(R, 2).Height - 1
End With
fs = Dir
Loop
End Sub

複製代碼

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)