[已解决]关于提取文件名及文件夹名称

流星的承诺

        提取切割文件夹时只提取D列“程序名称”下的文件名，要求，把切割文件夹下的文件夹名提取到图号下，对应文件夹下的“程序名称”。有两个文件夹以上的，中间就空一行做为分界。效果图见表格！！

并把*.3b文本第三行的“Length=     299.553 mm”，中的数值“299.553”提取到“线长L=”列下对应的“程序名称”效果图见表格。

另外提取文件名及图号文件夹时需要的窗口是下面这样的。

最佳答案

月排行榜 / 总排行榜

grf1973

2016-6-23 15:20

1. '***********递归获取本文件夹及所有子文件夹下所有文件名，
   
2. Dim w(1 To 10000), s%
   
3. Sub 提取文件名()
   
4.   On Error Resume Next
   
5.   s = 0: d = [a1]
   
6.   zdir ThisWorkbook.Path & ""
   
7.   ReDim arr(1 To 2 * s, 1 To 5)
   
8.   Application.ScreenUpdating = False
   
9.   For i = 1 To s
   
10.     Open w(i) For Input As #1
    
11.     wrr = Split(w(i), ""): k = UBound(wrr)
    
12.     Do While Not EOF(1)
    
13.         Line Input #1, x   '读入每行
    
14.         If InStr(x, "Length=") > 0 Then
    
15.             l = Val(Split(x, "Length=")(1))
    
16.             n = n + 1
    
17.             If n > 1 Then If "" & wrr(k - 1) & "" <> arr(n - 1, 1) Then n = n + 1
    
18.             arr(n, 1) = "" & wrr(k - 1) & ""
    
19.             arr(n, 4) = wrr(k)
    
20.             arr(n, 5) = l
    
21.         End If
    
22.     Loop
    
23.     Close #1
    
24.    Next
    
25.    
    
26.    For i = n To 2 Step -1
    
27.     If arr(i, 1) = arr(i - 1, 1) Then arr(i, 1) = ""
    
28.    Next
    
29.     Sheet1.[a3].Resize(n, 5) = arr
    
30.   Application.ScreenUpdating = True
    
31. End Sub
    
32. 
    
33. 
    
34. Sub zdir(p)       '递归获得本文件夹及所有子文件夹内文件名
    
35.   Set fs = CreateObject("scripting.filesystemobject")
    
36.   For Each f In fs.GetFolder(p).Files
    
37.     If f <> ThisWorkbook.FullName Then s = s + 1: w(s) = f
    
38.   Next
    
39.   For Each m In fs.GetFolder(p).SubFolders
    
40.       zdir m
    
41.   Next
    
42. End Sub
    

复制代码

跳转到最佳答案楼层

流星的承诺

“切割”文件夹不定盘符，我可以随便选择在哪个盘符下
不指定盘符，不指定文件夹
VB实现一部分

流星的承诺

请大神们帮帮忙

grf1973

1. '***********递归获取本文件夹及所有子文件夹下所有文件名，
   
2. Dim w(1 To 10000), s%
   
3. Sub 提取文件名()
   
4.   On Error Resume Next
   
5.   s = 0: d = [a1]
   
6.   zdir ThisWorkbook.Path & ""
   
7.   ReDim arr(1 To 2 * s, 1 To 5)
   
8.   Application.ScreenUpdating = False
   
9.   For i = 1 To s
   
10.     Open w(i) For Input As #1
    
11.     wrr = Split(w(i), ""): k = UBound(wrr)
    
12.     Do While Not EOF(1)
    
13.         Line Input #1, x   '读入每行
    
14.         If InStr(x, "Length=") > 0 Then
    
15.             l = Val(Split(x, "Length=")(1))
    
16.             n = n + 1
    
17.             If n > 1 Then If "" & wrr(k - 1) & "" <> arr(n - 1, 1) Then n = n + 1
    
18.             arr(n, 1) = "" & wrr(k - 1) & ""
    
19.             arr(n, 4) = wrr(k)
    
20.             arr(n, 5) = l
    
21.         End If
    
22.     Loop
    
23.     Close #1
    
24.    Next
    
25.    
    
26.    For i = n To 2 Step -1
    
27.     If arr(i, 1) = arr(i - 1, 1) Then arr(i, 1) = ""
    
28.    Next
    
29.     Sheet1.[a3].Resize(n, 5) = arr
    
30.   Application.ScreenUpdating = True
    
31. End Sub
    
32. 
    
33. 
    
34. Sub zdir(p)       '递归获得本文件夹及所有子文件夹内文件名
    
35.   Set fs = CreateObject("scripting.filesystemobject")
    
36.   For Each f In fs.GetFolder(p).Files
    
37.     If f <> ThisWorkbook.FullName Then s = s + 1: w(s) = f
    
38.   Next
    
39.   For Each m In fs.GetFolder(p).SubFolders
    
40.       zdir m
    
41.   Next
    
42. End Sub
    

复制代码

流星的承诺

grf1973 发表于 2016-6-23 15:20

大神，你这个是必须拷贝到文件夹内才可以的，能改成用窗口的吗。

grf1973

.....

流星的承诺

grf1973 发表于 2016-6-27 13:36
.....

谢谢大神，这就是我需要的。