工作簿里的数据批量提取，提取后以原工作簿名称单独保存

海利子

各位大佬，手动提取数据太浪费时间，自己也编了一个VBA程序但只能实现单个工作簿的数据提取，但还是不能提高效率，彻底放弃自己捣鼓了。请各位老师帮忙看一下，帮忙编写一段程序，实现快速批量提取数据，最好用VBA字典和数组实现快速，先谢谢各位大佬了。程序最好实现如下功能：
1、批量处理：通过选择文件夹的方法将xls或xlsx文件导入批量导入（工作簿内工作表数据格式均一致），要求提取工作簿数据后以原工作簿名称进行保存（原始数据可被替换）；
2、提取数据：每个工作簿提取的数据包括“EBAResult”工作表的D、E列数据，导出后数据样式见处理后数据：A1：B3为表头,其中导出数据B3随每个工作簿变化，是从Coil工作表C2单元格取值，D、E列的数据从第4行开始储存。
PS: 取出数据的程序最好具有通用性，可根据需求从“EBAResult”工作表增加。

ykcbf1100

多文件批量提取

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.3
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     p1 = p & "原始数据"
   
8.     p2 = p & "处理后数据"
   
9.     For Each f In fso.GetFolder(p1).Files
   
10.         If LCase$(f.Name) Like "*.xls*" Then
    
11.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
12.                 fn = fso.GetBaseName(f)
    
13.                 Set wb = Workbooks.Open(f, 0)
    
14.                 ReDim brr(1 To 100000, 1 To 2)
    
15.                 m = 3
    
16.                 With wb.Sheets("EBAResult")
    
17.                     r = .Cells(Rows.Count, 5).End(3).Row
    
18.                     arr = .[d1].Resize(r, 2)
    
19.                 End With
    
20.                 wb.Close False
    
21.                 brr(1, 1) = "Length": brr(1, 2) = "PS"
    
22.                 brr(2, 1) = "m": brr(2, 2) = "W/Kg"
    
23.                 brr(3, 1) = "钢卷长度": brr(3, 2) = "E182T01901"
    
24.                 Application.SheetsInNewWorkbook = 1
    
25.                 Set wb = Workbooks.Add
    
26.                 For i = 2 To UBound(arr)
    
27.                     m = m + 1
    
28.                     brr(m, 1) = arr(i, 1)
    
29.                     brr(m, 2) = arr(i, 2)
    
30.                 Next
    
31.                 wb.Sheets(1).Name = "EBAResult"
    
32.                 wb.Sheets(1).[a1].Resize(m, 2) = brr
    
33.                 wb.SaveAs p2 & fn
    
34.                 wb.Close
    
35.             End If
    
36.         End If
    
37.     Next f
    
38.     Application.ScreenUpdating = True
    
39.     MsgBox "OK！"
    
40. End Sub
    

复制代码

海利子

ykcbf1100 发表于 2024-8-3 21:56
多文件批量提取

谢谢大神出手，编写的语言简单明了，我忙活了一天也没好。还有一个小问题，导出的文件B3表头内容没实现随着工作簿名（前10位）或Coil工作表的C2内容变化而变化，这个内容对数据后续使用很重要，能否再帮忙修改一下。另外，如果能实现手动选择导入文件的文件夹及导出文件的文件夹就更好啦

海利子

ykcbf1100 发表于 2024-8-3 21:56
多文件批量提取

大神，只将程序里的brr(3, 2) = “E182T01901”修改为brr(3, 2) = Left(f.Name, 10)，C3表头就随着工作簿名称变化了。程序的通用性真好，拜服在地了。

ykcbf1100

海利子 发表于 2024-8-3 22:19
谢谢大神出手，编写的语言简单明了，我忙活了一天也没好。还有一个小问题，导出的文件B3表头内容没实现随 ...

改好了。。。

ykcbf1100

代碼更新一下，文件夾可選擇。

1. Sub ykcbf()   '//2024.8.4
   
2.     Set fso = CreateObject("scripting.filesystemobject")
   
3.     Application.ScreenUpdating = False
   
4.     Application.DisplayAlerts = False
   
5.     Set sh = ThisWorkbook.Sheets("Sheet1")
   
6.     p = ThisWorkbook.Path & ""
   
7.     With Application.FileDialog(msoFileDialogFolderPicker)
   
8.         .Title = "请选择原始数据文件夹"
   
9.         .InitialFileName = ThisWorkbook.Path & ""
   
10.         If .Show = -1 Then
    
11.             p1 = .SelectedItems(1) & ""
    
12.         End If
    
13.     End With
    
14.     With Application.FileDialog(msoFileDialogFolderPicker)
    
15.         .Title = "请选择处理后数据文件夹"
    
16.         .InitialFileName = ThisWorkbook.Path & ""
    
17.         If .Show = -1 Then
    
18.             p2 = .SelectedItems(1) & ""
    
19.         End If
    
20.     End With
    
21.     For Each f In fso.GetFolder(p1).Files
    
22.         If LCase$(f.Name) Like "*.xls*" Then
    
23.             If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
24.                 fn = fso.GetBaseName(f)
    
25.                 Set wb = Workbooks.Open(f, 0)
    
26.                 ReDim brr(1 To 100000, 1 To 2)
    
27.                 m = 3
    
28.                 With wb.Sheets("EBAResult")
    
29.                     r = .Cells(Rows.Count, 5).End(3).Row
    
30.                     arr = .[d1].Resize(r, 2)
    
31.                 End With
    
32.                 brr(1, 1) = "Length": brr(1, 2) = "PS"
    
33.                 brr(2, 1) = "m": brr(2, 2) = "W/Kg"
    
34.                 brr(3, 1) = "钢卷长度": brr(3, 2) = wb.Sheets("Coil").[c2].Value
    
35.                 wb.Close False
    
36.                 Application.SheetsInNewWorkbook = 1
    
37.                 Set wb = Workbooks.Add
    
38.                 For i = 2 To UBound(arr)
    
39.                     m = m + 1
    
40.                     brr(m, 1) = arr(i, 1)
    
41.                     brr(m, 2) = arr(i, 2)
    
42.                 Next
    
43.                 wb.Sheets(1).Name = "EBAResult"
    
44.                 wb.Sheets(1).[a1].Resize(m, 2) = brr
    
45.                 wb.SaveAs p2 & fn
    
46.                 wb.Close
    
47.             End If
    
48.         End If
    
49.     Next f
    
50.     Application.ScreenUpdating = True
    
51.     MsgBox "OK！"
    
52. End Sub
    

复制代码

海利子

ykcbf1100 发表于 2024-8-4 08:11
改好了。。。

感谢再次改进，完全满足要求！！！