返回列表 上一主題 發帖

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

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

        靜思自在 : 不要小看自己，因為人有無限的可能。
返回列表 上一主題