如何提取工作簿的名称

秦时明月夜

学习 备用{:soso_e181:}

kjq1833

zhaogang1960 发表于 2009-10-6 13:47
请测试:
Private Sub Workbook_Open()
    Dim mypath$, myfile$, mydir$, arr() As String, m%, n%, i%, ...

请问，把文件夹下（包含子文件夹）所以文件名提取到指定列（放在同一个子表中），如何实现呢？

zhaogang1960

kjq1833 发表于 2014-1-21 22:04
请问，把文件夹下（包含子文件夹）所以文件名提取到指定列（放在同一个子表中），如何实现呢？

请参考：

1. Sub Macro1()
   
2.     Dim Fso As Object, Folder As Object
   
3.     Dim arrf$(), mf&
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set Folder = Fso.GetFolder(ThisWorkbook.Path)
   
6.     Call GetFiles(Folder, arrf, mf)
   
7.     [a:a].ClearContents
   
8.     [a1].Resize(mf) = WorksheetFunction.Transpose(arrf)
   
9. End Sub
   
10. 
    
11. Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
    
12.     Dim SubFolder As Object
    
13.     Dim File As Object
    
14.     For Each File In Folder.Files
    
15.         If File.Name Like "*.xls" Then
    
16.             If File.Name <> ThisWorkbook.Name Then
    
17.                 mf = mf + 1
    
18.                 ReDim Preserve arrf(1 To mf)
    
19.                 arrf(mf) = File
    
20.             End If
    
21.         End If
    
22.     Next
    
23.     For Each SubFolder In Folder.SubFolders
    
24.         Call GetFiles(SubFolder, arrf, mf)
    
25.     Next
    
26. End Sub
    

复制代码

kjq1833

zhaogang1960 发表于 2014-1-21 23:01
请参考：

运行出错，70，拒绝的权限。。。
您帮忙再看看？

zhaogang1960

kjq1833 发表于 2014-1-22 22:25
运行出错，70，拒绝的权限。。。
您帮忙再看看？

如果你在根目录使用，有的文件夹是受系统保护的，不能访问，加一句错误处理：

1. Sub Macro1()
   
2.     Dim Fso As Object, Folder As Object
   
3.     Dim arrf$(), mf&
   
4.     Set Fso = CreateObject("Scripting.FileSystemObject")
   
5.     Set Folder = Fso.GetFolder(ThisWorkbook.Path)
   
6.     Call GetFiles(Folder, arrf, mf)
   
7.     [a:a].ClearContents
   
8.     [a1].Resize(mf) = WorksheetFunction.Transpose(arrf)
   
9. End Sub
   
10. 
    
11. Sub GetFiles(ByVal Folder As Object, ByRef arrf$(), ByRef mf&)
    
12.     Dim SubFolder As Object
    
13.     Dim File As Object
    
14.     On Error Resume Next
    
15.     For Each File In Folder.Files
    
16.         If File.Name Like "*.xls" Then
    
17.             If File.Name <> ThisWorkbook.Name Then
    
18.                 mf = mf + 1
    
19.                 ReDim Preserve arrf(1 To mf)
    
20.                 arrf(mf) = File
    
21.             End If
    
22.         End If
    
23.     Next
    
24.     For Each SubFolder In Folder.SubFolders
    
25.         Call GetFiles(SubFolder, arrf, mf)
    
26.     Next
    
27. End Sub
    

复制代码

kjq1833

zhaogang1960 发表于 2014-1-22 23:26
如果你在根目录使用，有的文件夹是受系统保护的，不能访问，加一句错误处理：

抱歉这么晚才测试，测试结果为显示名称、路径及扩展名。
现有几个问题还得向您请教：
1-能否生成一个总表，包含所有文件名称（不显示路径及扩展名）
2-生成每个文件夹的子表，字表内容为每个文件夹下的文件名称，子表名称为文件夹名称
3-生成一个目录，目录为每个子表的目录
以上所有均能链接。
另您在53楼的代码中，需先创建一个名称为总目录的子表，否则无法执行~

1122wen

看了半天，最终完美版是哪个呀

沙漠滴雨

赵老师的确是我们在学习vba路上的良师！

唔识电脑的家伙

几年后再看，觉得高人遍天下，除了技术高以外还孜孜不倦，特别是zhaogang1960  先生，真的很佩服！！！！！

hedkeke

3楼的代码牛