遍历几个指定文件夹下所有Excel文件并提取相同单元格中的数据

cnetkevin · 发表于 2017-4-11 16:29

遍历几个指定文件夹下所有Excel文件并提取相同单元格中的数据，请看附件，感谢帮助。

liulang0808 · 发表于 2017-4-11 17:49

http://club.excelhome.net/thread-1258425-1-1.html
看看这个资料，能否帮到你吧

cnetkevin · 发表于 2017-4-12 09:15

liulang0808 发表于 2017-4-11 17:49
http://club.excelhome.net/thread-1258425-1-1.html
看看这个资料，能否帮到你吧

谢谢，这个帖子内容很全，但是我水平有限，消化起来有难度，还是希望高手能帮忙把代码写好

liulang0808 · 发表于 2017-4-12 10:16

Public sh
Sub 按钮1_Click()
Application.ScreenUpdating = False
ActiveSheet.UsedRange.ClearContents
Cells(1, 1) = "提取A1的值"
Cells(1, 2) = "提取C4的值"
Cells(1, 3) = "文件名"
Set sh = ActiveSheet
Getfd (ThisWorkbook.Path) 'ThisWorkbook.Path是当前代码文件所在路径，路径名可以根据需求修改
Application.ScreenUpdating = True
End Sub
Sub Getfd(ByVal pth)

Set Fso = CreateObject("scripting.filesystemobject")
Set ff = Fso.getfolder(pth)
For Each f In ff.Files
      If InStr(Split(f.Name, ".")(UBound(Split(f.Name, "."))), "xl") > 0 Then
         If InStr(f.Name, "汇总") = 0 Then
            Set wb = Workbooks.Open(f)
            For Each sht In wb.Sheets
                  sh.Cells(Rows.Count, 1).End(3).Offset(1) = sht.[a1]
                  sh.Cells(Rows.Count, 2).End(3).Offset(1) = sht.[c4]
                  sh.Cells(Rows.Count, 3).End(3).Offset(1) = f.Name
            Next sht
            wb.Close False
         End If
      End If
Next f
For Each fd In ff.subfolders
      Getfd (fd)
Next fd
End Sub

liulang0808 · 发表于 2017-4-12 10:16

附件内容供参考

cnetkevin · 发表于 2017-4-12 12:19

十分感谢，但是还有一点问题。
附件代码是提取当前文件所在文件夹下所有子文件夹中的excel文件。
我是希望在汇总.xlsm的sheet1中的B列指定一些目录，这些目录是互相没有关系的，而且后期还会添加。
只要这些目录当前文件夹下就可以了，不需要遍历所有子文件夹。
能再帮忙改一下代码吗？

jygzcj · 发表于 2021-12-30 23:09

liulang0808 发表于 2017-4-12 10:16
Public sh
Sub 按钮1_Click()
Application.ScreenUpdating = False

这个递归的代码一直是往下挖子文件夹的文件，如果一个文件夹里有多个文件夹的话，其它文件夹里面的文件能读取的到？想破了头都想不到，能将所有文件下面的excel带出来的。

Dim i As Long
Sub test()
Application.ScreenUpdating = False
getfd ("C:\Users\zhangyanan\Desktop\excel\《Excel 2016函数与公式应用大全》示例文件")
Application.ScreenUpdating = True
End Sub
Sub getfd(ByVal fpath)
Dim fso As Object
Set fso = CreateObject("scripting.filesystemobject")
Dim fd As Object
Dim fl As Object
Set fd = fso.getfolder(fpath)
For Each fl In fd.Files
If fl.Name Like "*xlsx" Then
i = i + 1
Sheet1.Cells(i, 1) = fl.Name
End If
Next
Dim ff As Object
For Each ff In fd.subfolders
getfd (ff)
Next
End Sub

复制代码

ykcbf1100 · 发表于 2021-12-31 09:48

cnetkevin 发表于 2017-4-12 12:19
十分感谢，但是还有一点问题。
附件代码是提取当前文件所在文件夹下所有子文件夹中的excel文件。
我是希 ...

我知道已经过去了4年多了，不需求解答了。
我就练个手，自己解下题吧，提高一下自己。

moonwfa · 发表于 2022-12-14 11:19

下面是一个示例代码，该代码遍历了一个指定文件夹下的所有 Excel 文件，并提取了相同单元格中的数据：Sub ExtractDataFromExcelFiles() ' Define variables Dim folderPath As String Dim fileName As String Dim fullFileName As String Dim targetWorkbook As Workbook Dim targetWorksheet As Worksheet ' Specify the folder path folderPath = "C:\MyExcelFiles\" ' Loop through all Excel files in the specified folder fileName = Dir(folderPath & "*.xlsx") Do While fileName <> "" ' Construct the full file name fullFileName = folderPath & fileName ' Open the workbook Set targetWorkbook = Workbooks.Open(fullFileName) ' Set the target worksheet Set targetWorksheet = targetWorkbook.Worksheets("Sheet1") ' Extract the data from the specified cell Debug.Print targetWorksheet.Range("A1").Value ' Close the workbook targetWorkbook.Close ' Get the next file name fileName = Dir() Loop End Sub

		自动登录	找回密码
密码			免费注册

[求助] 遍历几个指定文件夹下所有Excel文件并提取相同单元格中的数据

评分