請問如何在不打開所有檔案下，複製指定儲存格內容至新檔案中，快速完成資料彙整？

chou680702

因工作上需要彙整之前提供給各單位之檔案(格式相同)，只需要彙整這些格式相同檔案中某些特定儲存格的資料。
但每次因為都要打開檔案-->複製儲存格資料-->貼在新檔案-->關閉舊檔案，依彙整檔案數量多寡重覆進行多次，且浪費很多時間。
因對於VBA還沒有很熟，需要請教各位高手，如何用VBA，將同一個資料夾中多個相同格式的檔案，將這些檔案內某些特定儲存格的資料，快速完成彙整的動作。
例如：要複製檔案A、檔案B、檔案C的B2及B8在新檔案中的A2及B2、A3及B3、A4及B4中。

wudixin96

1. Public Sub ZL1()
   
2. F = Dir(ThisWorkbook.path & "\*.xls")
   
3. Do While F <> ""
   
4.    If F <> ActiveWorkbook.Name Then
   
5.     S = S & "/" & F
   
6.    End If
   
7.   F = Dir
   
8. Loop
   
9. For Each F In Split(Right(S, Len(S) - 1), "/")
   
10.   With Sheet1.[a65536].End(xlUp)
    
11.      .Offset(1, 0) = GetValue(ThisWorkbook.path, F, "Sheet1", "B2")
    
12.      .Offset(1, 1) = GetValue(ThisWorkbook.path, F, "Sheet1", "B8")
    
13.   End With
    
14. Next
    
15. End Sub
    
16. Private Function GetValue(path, file, sheet, ref)
    
17. '   从未打开的Excel文件中检索数据
    
18.     Dim arg As String
    
19. '   确保该文件存在
    
20.     If Right(path, 1) <> "" Then path = path & ""
    
21.     If Dir(path & file) = "" Then
    
22.         GetValue = "File Not Found"
    
23.         Exit Function
    
24.     End If
    
25. '   创建变量
    
26.     arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
    
27.       Range(ref).Range("A1").Address(, , xlR1C1)
    
28. '   执行XLM 宏
    
29.     GetValue = ExecuteExcel4Macro(arg)
    
30. End Function
    

复制代码

试下吧

chou680702

複製貼上程式碼後，執行第一段(ZL1)是可以達成我要的目的，但有幾點想請教一下：
1.程式分為二個段落，若滑鼠停在第二段執行(GetValue)時，沒有作用。請問第二段程式的目的是？
2.延伸思考：如果資料來源不只在B2及B8等B欄，而是在B2、C3、D4等，程式要如何修正？是否為：
With Sheet1.[a65536].End(xlUp)
     .Offset(1, 0) = GetValue(ThisWorkbook.path, F, "Sheet1", "B2")
     .Offset(1, 1) = GetValue(ThisWorkbook.path, F, "Sheet1", "C3")
     .Offset(1, 2) = GetValue(ThisWorkbook.path, F, "Sheet1", "D4")
  End With

再麻煩指教一下。

wudixin96

第二段是函数，为第一段所调用执行。

理论你修改的代码是正确的。你可以试验一下。

chou680702

果然可行，非常感謝!