返回列表 上一主題 發帖

[發問] 如何將file夾圖檔一次全部帶入excel表格裡

jaga0828

帖子
26 
主題
9 
精華
0 
積分
58 
點名
0  
作業系統
WIN8 
軟體版本
A 
閱讀權限
20 
性別
男 
註冊時間
2014-5-19 
最後登錄
2020-4-17 
1# 跳轉到 »
發表於 2014-5-29 21:32 | 只看該作者

如何將圖片檔匯入EXCEL制定格式內

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

123.jpg (165 KB)

123.jpg

TOP

jaga0828

帖子
26 
主題
9 
精華
0 
積分
58 
點名
0  
作業系統
WIN8 
軟體版本
A 
閱讀權限
20 
性別
男 
註冊時間
2014-5-19 
最後登錄
2020-4-17 
2#
發表於 2014-5-30 22:28 | 只看該作者
請各位高高手幫忙小弟一下阿~!!!
感謝~

TOP

jaga0828

帖子
26 
主題
9 
精華
0 
積分
58 
點名
0  
作業系統
WIN8 
軟體版本
A 
閱讀權限
20 
性別
男 
註冊時間
2014-5-19 
最後登錄
2020-4-17 
3#
發表於 2014-5-30 23:16 | 只看該作者
小弟有找到一篇舊文章，但這篇文章的程式碼主要是將照片放在同一欄，名稱在另外一欄
小弟將所需的圖片檔案都放置 D:/TEST 裡面
按巨集=>圖片依序貼上B欄的儲存格 然後  C欄依序顯示出檔名
但小弟想請教大家要改為=>圖片依序在A1欄名稱 ->B1欄圖片->C1攔名稱->D1欄圖片   然後在排回A2欄名稱 ->B2欄圖片->C2攔名稱->D2欄圖片 ...........
請問各位高手依照下面程式碼可以改為我上面的需求?
感謝大家~
  1. Sub PHOTO()
  2. ActiveSheet.Columns("C") = ""
  3. Set Sh = ActiveSheet
  4. With Sh
  5.     .Pictures.Delete
  6. End With
  7. fs = Dir("D:\TEST\*.jpg")
  8. Do Until fs = ""
  9.    R = R + 1
  10.    Cells(R, 3) = fs
  11.    Cells(R, 2).Select
  12.    ActiveSheet.Pictures.Insert("D:\TEST\" & Cells(R, 3)).Select
  13.    With Selection
  14.        .Top = ActiveSheet.Cells(R, 2).Top + 1
  15.        .Left = ActiveSheet.Cells(R, 2).Left + 1
  16.        .Width = ActiveSheet.Cells(R, 2).Width - 1
  17.        .Height = ActiveSheet.Cells(R, 2).Height - 1
  18.    End With
  19.    fs = Dir
  20. Loop
  21. End Sub
複製代碼

TOP

jaga0828

帖子
26 
主題
9 
精華
0 
積分
58 
點名
0  
作業系統
WIN8 
軟體版本
A 
閱讀權限
20 
性別
男 
註冊時間
2014-5-19 
最後登錄
2020-4-17 
4# 倒序看帖
打印
tT
發表於 2014-5-31 23:08 | 只看該作者

[發問] 如何將file夾圖檔一次全部帶入excel表格裡

小弟有找到一篇舊文章，但這篇文章的程式碼主要是將照片放在同一欄，名稱在另外一欄
小弟將所需的圖片檔案都放置 D:/TEST 裡面
按巨集=>圖片依序貼上B欄的儲存格 然後  C欄依序顯示出檔名
但小弟想請教大家要改為=>圖片依序在A1欄名稱 ->B1欄圖片->C1攔名稱->D1欄圖片   然後在排回A2欄名稱 ->B2欄圖片->C2攔名稱->D2欄圖片 ...........
請問各位高手依照下面程式碼可以改為我上面的需求?
感謝大家~
  1. Sub PHOTO()
  2. ActiveSheet.Columns("C") = ""
  3. Set Sh = ActiveSheet
  4. With Sh
  5.     .Pictures.Delete
  6. End With
  7. fs = Dir("D:\TEST\*.jpg")
  8. Do Until fs = ""
  9.    R = R + 1
  10.    Cells(R, 3) = fs
  11.    Cells(R, 2).Select
  12.    ActiveSheet.Pictures.Insert("D:\TEST\" & Cells(R, 3)).Select
  13.    With Selection
  14.        .Top = ActiveSheet.Cells(R, 2).Top + 1
  15.        .Left = ActiveSheet.Cells(R, 2).Left + 1
  16.        .Width = ActiveSheet.Cells(R, 2).Width - 1
  17.        .Height = ActiveSheet.Cells(R, 2).Height - 1
  18.    End With
  19.    fs = Dir
  20. Loop
  21. End Sub
複製代碼
收藏 分享

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-6-1 07:01 | 只看該作者
本帖最後由 GBKEE 於 2014-6-1 20:28 編輯

回復 4# jaga0828
試試看
  1. Option Explicit
  2. Sub Ex()
  3.     Dim AR(), i As Integer, ii As Integer, fs As String, Rng As Range
  4.     With ActiveSheet
  5.         .Cells = ""
  6.         .Pictures.Delete
  7.         fs = Dir("D:\test\*.jpg")
  8.         Do Until fs = ""
  9.             ReDim Preserve AR(0 To i)
  10.             AR(i) = fs  '圖片名稱置入陣列
  11.             fs = Dir
  12.             i = i + 1
  13.         Loop
  14.         For i = 0 To UBound(AR) Step 2
  15.             For ii = 0 To 1
  16.                 If ii + i <= UBound(AR) Then
  17.                     .Cells(Int(i / 2) + 1, 1 + (ii * 2)) = AR(ii + i)
  18.                     Set Rng = .Cells(Int(i / 2) + 1, 2 + (ii * 2))
  19.                     With .Pictures.Insert("D:\test\" & AR(ii + i))
  20.                         .Top = Rng.Top
  21.                         .Left = Rng.Left
  22.                         .Width = Rng.Width
  23.                         .Height = Rng.Height
  24.                 End With
  25.                 End If
  26.             Next
  27.         Next
  28.     End With
  29. End Sub
複製代碼
  1. Sub Ex_1()
  2.     Dim f As Object, E As Object, Rng As Range, i  As Integer
  3.     Set f = CreateObject("Scripting.FileSystemObject").getfolder("D:\test").Files
  4.     With ActiveSheet
  5.         .Cells = ""
  6.         .Pictures.Delete
  7.         i = 1
  8.         For Each E In f
  9.             If LCase(E) Like "*.jpg" Then
  10.                 If i Mod 2 > 0 Then
  11.                     Set Rng = .Cells(Int(i / 2) + 1, 1)
  12.                 Else
  13.                     Set Rng = .Cells(i - Int(i / 2), 3)
  14.                 End If
  15.                 Rng.Value = E
  16.                 With .Pictures.Insert(E)
  17.                     .Top = Rng.Cells(1, 2).Top
  18.                     .Left = Rng.Cells(1, 2).Left
  19.                     .Width = Rng.Cells(1, 2).Width
  20.                     .Height = Rng.Cells(1, 2).Height
  21.                 End With
  22.                 i = i + 1
  23.             End If
  24.         Next
  25.     End With
  26. End Sub
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

jaga0828

帖子
26 
主題
9 
精華
0 
積分
58 
點名
0  
作業系統
WIN8 
軟體版本
A 
閱讀權限
20 
性別
男 
註冊時間
2014-5-19 
最後登錄
2020-4-17 
6#
發表於 2014-6-1 13:48 | 只看該作者
感謝GBKEE大大的幫忙! 這裡高手真的很厲害，祝端午佳節愉快~

TOP

justinbaba

帖子
14 
主題
2 
精華
0 
積分
17 
點名
0  
作業系統
windows7 
軟體版本
office2010 
閱讀權限
10 
性別
男 
註冊時間
2014-10-22 
最後登錄
2018-7-24 
7#
發表於 2014-10-31 16:15 | 只看該作者
GBKEE大大 您好~~
好像第二段的執行時會跳出 無法取得 Pic 的 insert 屬性？
不知怎麼解決呢？

TOP

justinbaba

帖子
14 
主題
2 
精華
0 
積分
17 
點名
0  
作業系統
windows7 
軟體版本
office2010 
閱讀權限
10 
性別
男 
註冊時間
2014-10-22 
最後登錄
2018-7-24 
8#
發表於 2014-10-31 16:54 | 只看該作者
GBKEE  大..

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

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

1、可秀出中文檔名

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

3、圖檔屬性 自動變為 "大小位置隨儲存格而變"  
因為這部份如果忘記改的話~~執行了篩選功能後，圖跟原本右方相對應的數值、文字會錯亂
是否有更方便的方式能解決呢？
  1. Sub PHOTO()
  2. ActiveSheet.Columns("C") = ""
  3. Set Sh = ActiveSheet
  4. With Sh
  5.     .Pictures.Delete
  6. End With
  7. fs = Dir("D:\TEST\*.jpg")
  8. Do Until fs = ""
  9.    R = R + 1
  10.    Cells(R, 3) = fs
  11.    Cells(R, 2).Select
  12.    ActiveSheet.Pictures.Insert("D:\TEST\" & Cells(R, 3)).Select
  13.    With Selection
  14.        .Top = ActiveSheet.Cells(R, 2).Top + 1
  15.        .Left = ActiveSheet.Cells(R, 2).Left + 1
  16.        .Width = ActiveSheet.Cells(R, 2).Width - 1
  17.        .Height = ActiveSheet.Cells(R, 2).Height - 1
  18.    End With
  19.    fs = Dir
  20. Loop
  21. End Sub
複製代碼

TOP

        靜思自在 : 真正的愛心，是照顧好自己的這顆心。
返回列表 上一主題