[已解决]提取多个excel工作表内容到一个excel表内

sure

各位老师好：
我有一系列的测试数据，都放在一个文件夹下，我希望通过选取文件夹，将该文件夹下所有文件导入到一个excel里面进行汇总，每个文件的末尾是测试的序列号，譬如98865-1.00-002A-1.csv，ID是1； 98865-1.00-002A-8.csv，ID 是8，每个excel提取前2列；
demo文件是提取后的模板，source是数据源，
demo的“”summary”sheet的Board name需要提取，就是excel的文件名：98865-1.00-002A，同一文件夹下的所有Board name是一致的，只是测试的序列号不同；
"raw"sheet就是提取的所有excel的内容，title是：时间+测试的序列号。
还有可能需要提取时间不能太长，所以读取文件的脚本的效率要高一点。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-5-3 14:11

1. Sub 显示选定文件夹文件()       '调用Windows文件浏览器打开文件
   
2.     Range("A:A").ClearContents '清除
   
3.     Dim fso, fl, fp
   
4.     Dim wb As Workbook
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     fp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & ""
   
7.     With Sheets("RAW")
   
8.         .Cells.Clear: c = 1
   
9.         For Each fl In fso.getfolder(fp).Files
   
10.             If InStr(UCase(fl.Name), "CSV") > 0 Then
    
11.                 n = n + 1
    
12.                 xrr = Split(fl.Name, "-")
    
13.                 xh = Val(xrr(UBound(xrr)))   '序号
    
14.                 If n = 1 Then
    
15.                     If [b1] = "" Then r = 1 Else r = [b65536].End(3).Row + 1
    
16.                     Cells(r, 2) = Replace(fl.Name, "-" & xh & ".csv", "")   'Board
    
17.                 End If
    
18.                 Set wb = Workbooks.Open(fl)
    
19.                 wb.Worksheets(1).Columns("a:b").Copy .Cells(1, c)
    
20.                 .Cells(1, c + 1) = xh
    
21.                 c = c + 2
    
22.                 wb.Close False
    
23.            End If
    
24.         Next
    
25.     End With
    
26. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub 显示选定文件夹文件()       '调用Windows文件浏览器打开文件
   
2.     Range("A:A").ClearContents '清除
   
3.     Dim fso, fl, fp
   
4.     Dim wb As Workbook
   
5.     Set fso = CreateObject("Scripting.FileSystemObject")
   
6.     fp = CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path & ""
   
7.     With Sheets("RAW")
   
8.         .Cells.Clear: c = 1
   
9.         For Each fl In fso.getfolder(fp).Files
   
10.             If InStr(UCase(fl.Name), "CSV") > 0 Then
    
11.                 n = n + 1
    
12.                 xrr = Split(fl.Name, "-")
    
13.                 xh = Val(xrr(UBound(xrr)))   '序号
    
14.                 If n = 1 Then
    
15.                     If [b1] = "" Then r = 1 Else r = [b65536].End(3).Row + 1
    
16.                     Cells(r, 2) = Replace(fl.Name, "-" & xh & ".csv", "")   'Board
    
17.                 End If
    
18.                 Set wb = Workbooks.Open(fl)
    
19.                 wb.Worksheets(1).Columns("a:b").Copy .Cells(1, c)
    
20.                 .Cells(1, c + 1) = xh
    
21.                 c = c + 2
    
22.                 wb.Close False
    
23.            End If
    
24.         Next
    
25.     End With
    
26. End Sub
    

复制代码