Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 3610|回复: 11

[已解决]提取指定文件(怎样实现提取将文件名指定字段 续)

[复制链接]
发表于 2016-6-14 20:38 | 显示全部楼层 |阅读模式
本帖最后由 乐乐2006201506 于 2016-6-15 20:40 编辑

  • Sub 提取指定文件夹内的所有文件名() '含所有子文件夹内的文件
  •     Dim Fso As Object, arrf$(), mf&
  •     Set Fso = CreateObject("Scripting.FileSystemObject")
  •     Call GetFiles1(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path, Fso, arrf, mf)
  •     [B1].Resize(mf) = Application.Transpose(arrf)
  •     Set Fso = Nothing
  •     For i = 1 To UBound(arrf)
  •         Cells(i, 3) = "=Mid(B" & i & ", (Find(""("", B" & i & ") + 1), Find("")"", B" & i & ") - (Find(""("", B" & i & ") + 1))"
  •     Next
  • End Sub

请问:
1.怎样不通过b列数据辅助,直接在b列得到想要的结果;
2.怎样才能实现选择提取指定文件(如:.xls或.xlsx等)的文件名。
谢谢!



最佳答案
2016-6-15 16:55
这个代码是你的,我没改这个,你直接把中间这个“提取指定文件夹内的所有文件名公式”这个过程删掉就可以了,如下:
  1. Sub 提取指定文件夹内的所有文件名() '含所有子文件夹内的文件
  2.     Dim Fso As Object, arrf$(), mf&
  3.     Set Fso = CreateObject("Scripting.FileSystemObject")
  4.     Call GetFiles(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path, Fso, arrf, mf)
  5.     [B1].Resize(mf) = Application.Transpose(arrf)
  6.     Set Fso = Nothing
  7. End Sub
  8. Private Sub GetFiles(ByVal sPath$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
  9.     Dim Folder As Object
  10.     Dim SubFolder As Object
  11.     Dim File As Object
  12.     Dim En$
  13.     Set Folder = Fso.GetFolder(sPath)
  14.     For Each File In Folder.Files
  15.         En = Fso.GetExtensionName(sPath & "" & File.Name)
  16.         If En Like "*xls*" Then
  17.             mf = mf + 1
  18.             ReDim Preserve arrf(1 To mf)
  19.             arrf(mf) = Mid(File.Name, InStr(File.Name, "(") + 1, InStr(File.Name, ")") - InStr(File.Name, "(") - 1)
  20.         End If
  21.     Next
  22.     For Each SubFolder In Folder.SubFolders
  23.         Call GetFiles(SubFolder.Path, Fso, arrf, mf)
  24.     Next
  25.     Set Folder = Nothing
  26.     Set File = Nothing
  27. End Sub
复制代码

提取指定文件夹中文件名1.rar

13.64 KB, 下载次数: 36

发表于 2016-6-14 21:30 | 显示全部楼层
用FSO我记得好像不能选择某一类文件,用DIR相对比较简单一点,但读取子文件夹确实用FSO做递归是比较方便的,明天我抽时间想想,昨天晚上代码写的失眠了,今天早点休息了!
回复

使用道具 举报

 楼主| 发表于 2016-6-14 21:36 | 显示全部楼层
老司机带带我 发表于 2016-6-14 21:30
用FSO我记得好像不能选择某一类文件,用DIR相对比较简单一点,但读取子文件夹确实用FSO做递归是比较方便的, ...

        谢谢您,不管怎么样,要保重身体,准时休息!
回复

使用道具 举报

发表于 2016-6-15 09:53 | 显示全部楼层
稍微做了点改动,第二个问题通过判断文件的后缀名来实现,第一个问题虽然实现了,但我不是很建议这种做法,具体看代码注解。
  1. Sub 提取指定文件夹内的所有文件名() '含所有子文件夹内的文件
  2.     Dim Fso As Object, arrf$(), mf&
  3.     Set Fso = CreateObject("Scripting.FileSystemObject")
  4.     Call GetFiles(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path, Fso, arrf, mf)
  5.     [B1].Resize(mf, 2) = Application.Transpose(arrf)  '这里必须从第一行开始,即可用是A1,C1,单B2,A2都不行
  6.     Set Fso = Nothing
  7. End Sub
  8. Sub 提取指定文件夹内的所有文件名公式() '含所有子文件夹内的文件
  9.     Dim Fso As Object, arrf$(), mf&, Find$()
  10.     Set Fso = CreateObject("Scripting.FileSystemObject")
  11.     Call GetFiles(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path, Fso, arrf, mf)
  12.     [B1].Resize(mf) = Application.Transpose(Mid(arrf, (Find("(", arrf) + 1), Find(")", arrf) - (Find("(", arrf) + 1)))
  13.     Set Fso = Nothing
  14. End Sub
  15. Private Sub GetFiles(ByVal sPath$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
  16.     Dim Folder As Object
  17.     Dim SubFolder As Object
  18.     Dim File As Object
  19.     Dim En$
  20.     Set Folder = Fso.GetFolder(sPath)
  21.     For Each File In Folder.Files
  22.         En = Fso.GetExtensionName(sPath & "" & File.Name)
  23.         If En Like "*xls*" Then
  24.             mf = mf + 1
  25.             ReDim Preserve arrf(1 To 2, 1 To mf)
  26.             arrf(1, mf) = File.Name
  27.             arrf(2, mf) = "=Mid(B" & mf & ", (Find(""("", B" & mf & ") + 1), Find("")"", B" & mf & ") - (Find(""("", B" & mf & ") + 1))"
  28.         End If
  29.     Next
  30.     For Each SubFolder In Folder.SubFolders
  31.         Call GetFiles(SubFolder.Path, Fso, arrf, mf)
  32.     Next
  33.     Set Folder = Nothing
  34.     Set File = Nothing
  35. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-6-15 12:05 | 显示全部楼层
        第2条已经实现,能不能将第1条实现,因为我原来的表在B列,其他列都有数据,甚至有绝对应用的单元格,增加辅助列会打乱我的公式的值,所以希望实现第1条的效果。谢谢!

        1.怎样不通过b列数据辅助,直接在b列得到想要的结果;
        2.怎样才能实现选择提取指定文件(如:.xls或.xlsx等)的文件名。
        谢谢!
回复

使用道具 举报

发表于 2016-6-15 14:16 | 显示全部楼层
乐乐2006201506 发表于 2016-6-15 12:05
第2条已经实现,能不能将第1条实现,因为我原来的表在B列,其他列都有数据,甚至有绝对应用的单元格 ...

第一条实际不是已经实现了吗?
他不是说一定要在B列,可以放在C列,D列,E列,任意,但是行必须放在第一行,如果说也是要跟着第一个设置的单元格走也行,再传递个行参数进去!
回复

使用道具 举报

 楼主| 发表于 2016-6-15 14:38 | 显示全部楼层
老司机带带我 发表于 2016-6-15 14:16
第一条实际不是已经实现了吗?
他不是说一定要在B列,可以放在C列,D列,E列,任意,但是行必须放在第一 ...

1.怎样不通过b列数据辅助,直接在b列得到想要的结果;


但我运行后还会在B列出现完整的文件名,在C列输入了公式,才达到了提取指定字段得目的。
是不是您把帮别人另外一个帖子的要求和我的混淆了?
回复

使用道具 举报

发表于 2016-6-15 14:56 | 显示全部楼层
乐乐2006201506 发表于 2016-6-15 14:38
1.怎样不通过b列数据辅助,直接在b列得到想要的结果;

看来是我一直没理解,看下对不对:
  1. Sub 提取指定文件夹内的所有文件名() '含所有子文件夹内的文件
  2.     Dim Fso As Object, arrf$(), mf&
  3.     Set Fso = CreateObject("Scripting.FileSystemObject")
  4.     Call GetFiles(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path, Fso, arrf, mf)
  5.     [B1].Resize(mf) = Application.Transpose(arrf)
  6.     Set Fso = Nothing
  7. End Sub
  8. Sub 提取指定文件夹内的所有文件名公式() '含所有子文件夹内的文件
  9.     Dim Fso As Object, arrf$(), mf&, Find$()
  10.     Set Fso = CreateObject("Scripting.FileSystemObject")
  11.     Call GetFiles(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path, Fso, arrf, mf)
  12.     [B1].Resize(mf) = Application.Transpose(Mid(arrf, (Find("(", arrf) + 1), Find(")", arrf) - (Find("(", arrf) + 1)))
  13.     Set Fso = Nothing
  14. End Sub
  15. Private Sub GetFiles(ByVal sPath$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
  16.     Dim Folder As Object
  17.     Dim SubFolder As Object
  18.     Dim File As Object
  19.     Dim En$
  20.     Set Folder = Fso.GetFolder(sPath)
  21.     For Each File In Folder.Files
  22.         En = Fso.GetExtensionName(sPath & "" & File.Name)
  23.         If En Like "*xls*" Then
  24.             mf = mf + 1
  25.             ReDim Preserve arrf(1 To mf)
  26.             arrf(mf) = Mid(File.Name, InStr(File.Name, "(") + 1, InStr(File.Name, ")") - InStr(File.Name, "(") - 1)
  27.         End If
  28.     Next
  29.     For Each SubFolder In Folder.SubFolders
  30.         Call GetFiles(SubFolder.Path, Fso, arrf, mf)
  31.     Next
  32.     Set Folder = Nothing
  33.     Set File = Nothing
  34. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2016-6-15 16:29 | 显示全部楼层
提取 类型不匹配.png 提取 无效.png
回复

使用道具 举报

发表于 2016-6-15 16:55 | 显示全部楼层    本楼为最佳答案   
这个代码是你的,我没改这个,你直接把中间这个“提取指定文件夹内的所有文件名公式”这个过程删掉就可以了,如下:
  1. Sub 提取指定文件夹内的所有文件名() '含所有子文件夹内的文件
  2.     Dim Fso As Object, arrf$(), mf&
  3.     Set Fso = CreateObject("Scripting.FileSystemObject")
  4.     Call GetFiles(CreateObject("Shell.Application").BrowseForFolder(0, "请选择文件夹", 0, "").Self.Path, Fso, arrf, mf)
  5.     [B1].Resize(mf) = Application.Transpose(arrf)
  6.     Set Fso = Nothing
  7. End Sub
  8. Private Sub GetFiles(ByVal sPath$, ByRef Fso As Object, ByRef arrf$(), ByRef mf&)
  9.     Dim Folder As Object
  10.     Dim SubFolder As Object
  11.     Dim File As Object
  12.     Dim En$
  13.     Set Folder = Fso.GetFolder(sPath)
  14.     For Each File In Folder.Files
  15.         En = Fso.GetExtensionName(sPath & "" & File.Name)
  16.         If En Like "*xls*" Then
  17.             mf = mf + 1
  18.             ReDim Preserve arrf(1 To mf)
  19.             arrf(mf) = Mid(File.Name, InStr(File.Name, "(") + 1, InStr(File.Name, ")") - InStr(File.Name, "(") - 1)
  20.         End If
  21.     Next
  22.     For Each SubFolder In Folder.SubFolders
  23.         Call GetFiles(SubFolder.Path, Fso, arrf, mf)
  24.     Next
  25.     Set Folder = Nothing
  26.     Set File = Nothing
  27. End Sub
复制代码
回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 22:10 , Processed in 1.375006 second(s), 17 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表