• 2

請問一下...VBA中如何把多個資料夾內所有EXCEL檔案中的特定儲存格存到新的EXCEL檔案中?

請問各位大大!
目前我有在"C:\維修單\"中有不同縣市(共12個)的資料夾..
且在"C:\維修單\高雄市\10月份\"底下有數量不一的維修單EXCEL檔案..
檔案名稱是:108年10月19日維修單(廠商名字).xlsx
而且是以當天的日期做檔案名稱標準..
我想把不同縣市的所有維修檔案中特定的幾個儲存格
如:"C1:D1","L1","I8:K8"等的內容以新開檔案(維修總表)的方式儲存到sheet(1):10月份中..
不知道該怎麼寫該程式..
請教各位大大一下~!
謝謝~!
2019-10-19 21:47 發佈
以下範例給您參考

流程:
先用變數記錄當前的的Excel (W1)
指定W1要填值的儲存格 (R1)
用迴圈進入各個子資料夾去抓各個文件
用Workbooks.Open開啟Excel (W2)
將W2特定儲存格的值指派給R1
填值完成後,讓R1指定的儲存格往下位移
關閉W2
開啟迴圈下一個Excel重複上述動作
持續上述動作到路徑下所有資料夾內的所有文件都做過一輪後結束

注意:
若Excel事先開啟,Workbooks.Open時會出錯

Sub Test()
Dr1 = "C:\維修單"
Set W1 = ActiveWorkbook
Set S1 = W1.Sheets(1)
Set R1 = S1.[A1]
With CreateObject("Scripting.FileSystemObject")
Set Drs = .GetFolder(Dr1).SubFolders
For Each Dr In Drs
Set Files = .GetFolder(Dr).Files
For Each File In Files
Workbooks.Open (File.Path)
Set W2 = Workbooks(File.Name)
Set S2 = W2.Sheets(1)
Range(R1, R1.Offset(0, 1)).Value = S2.[C1:D1].Value
R1.Offset(0, 2).Value = S2.[L1].Value
Range(R1.Offset(0, 3), R1.Offset(0, 5)).Value = S2.[I8:K8].Value
W2.Close
Set R1 = R1.Offset(1, 0)
Next File
Next Dr
End With
End Sub
如果您想檢查檔案是否開啟,微軟有一個相當不錯的官方vba範例
詳細請參考
https://support.microsoft.com/en-us/help/291295/macro-code-to-check-whether-a-file-is-already-open


Sub TestFileOpened()

' Test to see if the file is open.
If IsFileOpen("c:\Book2.xls") Then
' Display a message stating the file in use.
MsgBox "File already in use!"
'
' Add code here to handle case where file is open by another
' user.
'
Else
' Display a message stating the file is not in use.
MsgBox "File not in use!"
' Open the file in Microsoft Excel.
Workbooks.Open "c:\Book2.xls"
'
' Add code here to handle case where file is NOT open by another
' user.
'
End If

End Sub

' This function checks to see if a file is open or not. If the file is
' already open, it returns True. If the file is not open, it returns
' False. Otherwise, a run-time error occurs because there is
' some other problem accessing the file.

Function IsFileOpen(filename As String)
Dim filenum As Integer, errnum As Integer

On Error Resume Next ' Turn error checking off.
filenum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open filename For Input Lock Read As #filenum
Close filenum ' Close the file.
errnum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.

' Check to see which error occurred.
Select Case errnum

' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False

' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True

' Another error occurred.
Case Else
Error errnum
End Select

End Function
f10629 wrote:
以下範例給您參考流程...(恕刪)

感謝大大的分享!
我試了之後我有增加及修改一點東西..
但出現此錯誤訊息!
不知該如何處理!!
謝謝!!
jackhuang019 wrote:
感謝大大的分享!我試...(恕刪)


Files 被你在一開始定義為String了,但CreateObject("Scripting.FileSystemObject").GetFolder(Dr).Files回傳的是物件型態
把Files的定義改寫為Variant或Object就可以了

一般在VBA裡,不Dim就能直接使用變數,預設為Variant型態
平時為了書寫快速我都會偷懶不Dim
f10629 wrote:
一般在VBA裡,不Dim就能直接使用變數,預設為Variant型態
平時為了書寫快速我都會偷懶不Dim^++^...(恕刪)


小程式不用比較方便,程式寫久了,都會偷懶
"超"大型程式,就要注意一下了,都用Variant可能會有記憶體不足的問題
(通常只有要賣$的,我才會用心的定義所有變數)

但是,[ ] 括號,這種寫法,我是不管大小都不用,因為對速度有明顯的影響
請參考我2017年的舊發文
https://www.mobile01.com/topicdetail.php?f=511&t=5328464&p=1#66605795
snare wrote:
小程式不用比較方便,...(恕刪)


受教了!
原來對於效能影響還是有差異的
哪天程式跑太慢我一定記得回來檢查是不是[ ]和Variant用太多
f10629 wrote:
Files 被你在一...(恕刪)


各位大大!!
感謝教導~!
我在更改一些定義和設定後已經可以執行了~!
但開啟檔案的時候後出現下面的畫面!!
這應該是巨集方面是法要更新!!
如不要更新的話是否有方式不用每次都要按"不要更新"!!
謝謝大大的分享~!
jackhuang019 wrote:
各位大大!!感謝教導...(恕刪)


在程式一開始加這行,應該就不會跳東西出來了
Application.DisplayAlerts = False
f10629 wrote:
以下範例給您參考流程...(恕刪)

請問大大!!
因此程式是針對目標檔案中特定格式做一次性的抓取動作!
但某些資料夾中有些檔案內有多筆資料要抓取的話要如何處理呢?
也就是如:L1欄位有一次性的資料..
但D8:E8及I8:K8欄位有多筆資料(同一個檔案中)
那該如何處理呢?
謝謝大大!!
Sub 維修單單一分店資料匯入總表()
Dim W1, W2, S1, S2, R1, Dr1 As String
Dim Dr, File, files, Drs As Variant
Dim i As Integer

Application.ScreenUpdating = False '為了避免螢幕更新,造成測試時間拉長,先關閉

Application.DisplayAlerts = False '在巨集執行時隱藏提示和警告訊息不顯示出來

Dr1 = "C:\新版維修單\博愛\2019年"
Set W1 = ActiveWorkbook
Set S1 = W1.Sheets(2) '把抓取下來的資料放在分頁2中
Set R1 = S1.Range("A2") 'Set R1 = ActiveWorkbook.Sheets(1).[A1]
With CreateObject("Scripting.FileSystemObject")
Set Drs = .GetFolder(Dr1).SubFolders
For Each Dr In Drs '變數Dr在資料夾裡面做搜尋動作
Set files = .GetFolder(Dr).files
For Each File In files
Workbooks.Open (File.Path)
Set W2 = Workbooks(File.Name)
Set S2 = W2.Sheets(1)
Range(R1, R1.Offset(0, 1)).Value = S2.[C1:D1].Value '抓取C1D1的資料出來
R1.Offset(0, 2).Value = S2.Range("L1").Value '抓取L1的資料出來

'以下為測試單一檔案中有多筆資料要抓取
For i = 1 To 15

Range(R1.Offset(0, 3 + i), R1.Offset(0, 5 + i)).Value = S2.[D7+i:E7+i].Value '抓取D8E8的資料出來


Next i

'以上為測試單一檔案中有多筆資料要抓取
W2.Close
Set R1 = R1.Offset(1, 0)
Next File
Next Dr
End With

Application.ScreenUpdating = True

'Application.DisplayAlerts = True



End Sub
  • 2
限制級
您即將進入之討論頁 需滿18歲 方可瀏覽。
根據「電腦網路內容分級處理辦法」修正條文第六條第三款規定,已於該限制級網頁,依台灣網站分級推廣基金會規定作標示。
評分
複製連結