求助：我需要从三千多个工作簿中提取规定数据到新表

wxf020412

每个学生一个Excel表，里面有他各科成绩，标的格式完全一样，我需求提取每个学生的历次英语成绩到新表，各位大神帮帮忙

liulang0808

欢迎新朋友
http://club.excelhome.net/thread-1258425-1-1.html
遍历文件的资料，楼主参考下

大头菜871118

请加我QQ 450587502

大头菜871118

请见附件>>>>>>>>>>

liucf

文件多时不打开文件更快一些

LMY123

多薄指定表不连续单元格合并，Split("M2 D10 F10 H10 J10 M10 O10 Q10 S10")

大头菜871118

liucf 发表于 2018-3-21 10:29
文件多时不打开文件更快一些

你这个更快一些

abc123281

经供参考

1. Sub 提取英语数据()
   
2. Dim wb As Workbook
   
3. Dim arr(1 To 5000, 1 To 11)
   
4. Dim mypath$, myname$
   
5. Application.DisplayAlerts = False
   
6. Application.ScreenUpdating = False
   
7. mypath = ThisWorkbook.Path & ""
   
8. myname = Dir(mypath & "*.xl*")
   
9. Do While myname <> ""
   
10.    If myname <> ThisWorkbook.Name Then
    
11.       Set wb = GetObject(mypath & myname)
    
12.       With wb
    
13.         With .Worksheets("成绩学分登记表")
    
14.             n = n + 1
    
15.             arr(n, 1) = .[m2]
    
16.             arr(n, 2) = .[c2]
    
17.             arr(n, 3) = .[i2]
    
18.             arr(n, 4) = .[d10]
    
19.             arr(n, 5) = .[f10]
    
20.             arr(n, 6) = .[h10]
    
21.             arr(n, 7) = .[j10]
    
22.             arr(n, 8) = .[m10]
    
23.             arr(n, 9) = .[o10]
    
24.             arr(n, 10) = .[q10]
    
25.             arr(n, 11) = .[s10]
    
26.         End With
    
27.         wb.Close False
    
28.       End With
    
29.     End If
    
30. myname = Dir()
    
31. Loop
    
32. With ThisWorkbook.Worksheets("汇总")
    
33.   .[a4].Resize(UBound(arr), 11) = arr
    
34. End With
    
35. Application.DisplayAlerts = True
    
36. Application.ScreenUpdating = True
    
37. MsgBox "提取完成，请核查！"
    
38. End Sub

复制代码

abc123281

参考附件
、



提取英语成绩 abc123.rar (58.38 KB, 下载次数: 42)

2018-3-21 10:57 上传

点击文件名下载附件