批量提取文件名填入相应的行

cshzh

请教：同一文件夹下有多个文件，想提取文件名到考级汇总表的第一行相应的位置（B1-B8单元格）

并且将相应文件内的学生综合成绩填入相应书目的列中。如图

liulang0808

http://club.excelhome.net/thread-1258425-1-1.html
资料，楼主可以参考下爱

cshzh

liulang0808 发表于 2019-12-26 12:16
http://club.excelhome.net/thread-1258425-1-1.html
资料，楼主可以参考下爱

能不能直接帮我写一个啊，我不会

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     arr = ThisWorkbook.Sheets(1).[a1].CurrentRegion
   
4.     Application.ScreenUpdating = False
   
5.     For j = 2 To UBound(arr)
   
6.         If Len(arr(j, 1)) > 0 Then d(arr(j, 1)) = j
   
7.     Next j
   
8.     For i = 2 To UBound(arr, 2) - 1
   
9.         If Dir(ThisWorkbook.Path & "" & arr(1, i) & ".xls") <> "" Then
   
10.             With Workbooks.Open(ThisWorkbook.Path & "" & arr(1, i) & ".xls")
    
11.                 brr = .Sheets(1).UsedRange
    
12.                 .Close False
    
13.             End With
    
14.             For j = 3 To UBound(brr)
    
15.                 If d.exists(brr(j, 2)) Then
    
16.                     r = d(brr(j, 2))
    
17.                     arr(r, i) = brr(j, 5)
    
18.                 End If
    
19.             Next j
    
20.         End If
    
21.     Next i
    
22.     ThisWorkbook.Sheets(1).[a1].CurrentRegion = arr
    
23.     Application.ScreenUpdating = True
    
24. End Sub

复制代码

liulang0808

附件内容供参考。。。。。。

cshzh

liulang0808 发表于 2019-12-26 13:14
附件内容供参考。。。。。。

能汇总成绩，但提取文件名不行啊

liulang0808

cshzh 发表于 2019-12-26 13:23
能汇总成绩，但提取文件名不行啊

要怎么提取文件名？没有看出来

deadzlq

PQ参考解法

cshzh

liulang0808 发表于 2019-12-26 18:39
要怎么提取文件名？没有看出来

汇总表第一行A2到A9是没有书名的，要提取文件文件夹下的书名填入

liulang0808

1. Sub 按钮1_Click()
   
2.     Set d = CreateObject("scripting.dictionary")
   
3.     Set fso = CreateObject("scripting.filesystemobject")
   
4.     arr = ThisWorkbook.Sheets(1).[a1].CurrentRegion
   
5.     ActiveSheet.UsedRange.Offset(1, 1).ClearContents
   
6.     Application.ScreenUpdating = False
   
7.     For j = 2 To UBound(arr)
   
8.         If Len(arr(j, 1)) > 0 Then d(arr(j, 1)) = j
   
9.     Next j
   
10.     c = 2
    
11.     For Each f In fso.getfolder(ThisWorkbook.Path).Files
    
12.         ThisWorkbook.Sheets(1).Cells(1, c) = Split(f.Name, ".")(0)
    
13.         arr = ThisWorkbook.Sheets(1).[a1].CurrentRegion
    
14.         If InStr(f.Name, ThisWorkbook.Name) = 0 Then
    
15.             With Workbooks.Open(f)
    
16.                 brr = .Sheets(1).UsedRange
    
17.                 .Close False
    
18.             End With
    
19.             
    
20.             For j = 3 To UBound(brr)
    
21.                 If d.exists(brr(j, 2)) Then
    
22.                     r = d(brr(j, 2))
    
23.                     arr(r, c) = brr(j, 5)
    
24.                 End If
    
25.             Next j
    
26.             c = c + 1
    
27.             ThisWorkbook.Sheets(1).[a1].CurrentRegion = arr
    
28.         End If
    
29.     Next
    
30.     ThisWorkbook.Sheets(1).[a1].CurrentRegion = arr
    
31.     Application.ScreenUpdating = True
    
32. End Sub
    

复制代码