文件夹名称提取

yooha

前请辈帮忙代码提取下下级文件夹名,取_前段字符,结果以文本模式记录,谢谢

详情见附件 例子.zip (9.64 KB, 下载次数: 18)

2019-3-16 11:16 上传

点击文件名下载附件

maditate

1. Private Sub CommandButton1_Click()
   
2. Dim arr(1 To 1000) '监时需求，声明一个一千单元的数组
   
3. mypath = ThisWorkbook.Path & "/"
   
4. 目录 = Dir(mypath, 16)
   
5. h = 1
   
6. Do
   
7.   If 目录 = Empty Then Exit Do
   
8.    If InStr(目录, ".") = Empty Then
   
9.      arr(h) = 目录
   
10.      h = h + 1
    
11.      If h = 1000 Then
    
12.         MsgBox ("目录太多了，请重新设置数组下限。")
    
13.      End If
    
14.     End If
    
15.     目录 = Dir()
    
16. Loop
    
17.   On Error Resume Next
    
18. l = 2
    
19. For i = 1 To h - 1
    
20.      mypath = ThisWorkbook.Path & "/" & arr(i) & "/"
    
21. '     If arr(i) = Empty Then Exit For
    
22.     目录 = Dir(mypath, 16)
    
23.     Do
    
24.       If 目录 = Empty Then Exit Do
    
25.        If InStr(目录, ".") = Empty Then
    
26.           '此处可以添加语句以获取目录字符串中的子符串
    
27.       
    
28.            Cells(l, 1) = 目录
    
29.           l = l + 1
    
30.        End If
    
31.         目录 = Dir()
    
32.     Loop
    
33. Next i
    
34. End Sub
    

复制代码

ww87725244

1. Option Explicit
   
2. Dim ar(), k&
   
3. Function getfd(ByVal ph)
   
4. Dim d As Object, d1 As Object
   
5. With CreateObject("scripting.filesystemobject")
   
6.     For Each d In .getfolder(ph).subfolders
   
7.         If InStr(d.Name, "_") Then
   
8.             k = k + 1
   
9.             ReDim Preserve ar(1 To k)
   
10.             ar(k) = Split(d.Name, "_")(0)
    
11.         Else
    
12.             getfd (d)
    
13.         End If
    
14.     Next
    
15. End With
    
16. End Function
    
17. Sub aa()
    
18. Dim ph$
    
19. With Application.FileDialog(msoFileDialogFolderPicker)
    
20.     If .Show = -1 Then
    
21.         ph = .SelectedItems(1)
    
22.     Else
    
23.         Exit Sub
    
24.     End If
    
25. End With
    
26. getfd (ph)
    
27. If k = 0 Then
    
28.     MsgBox "不存在相关文件夹"
    
29.     Exit Sub
    
30. End If
    
31. With Sheet1
    
32.     .Range("g1").Resize(UBound(ar)).ClearContents
    
33.     .Range("g1").Resize(UBound(ar)).NumberFormatLocal = "@"
    
34.     .[g1].Resize(UBound(ar)) = Application.Transpose(ar)
    
35.     k = 0
    
36.     Erase ar
    
37. End With
    
38. End Sub

复制代码

不知道为什么

http://club.excelhome.net/thread-1466204-1-1.html

类似的问题重复提，自己不可以举一反三？

不知道为什么

如图

不知道为什么

kzg2013

Sub getsub()
Dim s$
s = ActiveWorkbook.Path
Columns("a").Clear
  Call GetSubFolder(s)
Set d = CreateObject("scripting.dictionary")
rr = UsedRange.Rows.Count
Rng = Range("a1:a" & rr)
For k = 1 To UBound(Rng)
    On Error Resume Next
    d.Add "'" & Rng(k, 1), ""
Next k
Columns("a").Clear
Cells(1, 1).Resize(d.Count, 1) = Application.Transpose(d.keys)

End Sub

Sub GetSubFolder(s As String)
Dim fso As Object
On Error Resume Next
Set fso = CreateObject("scripting.filesystemobject")
Set fd = fso.getfolder(s)
For Each subfd In fd.subfolders
                If fso.getParentfoldername(subfd) <> ActiveWorkbook.Path Then
                       tt = InStr(1, subfd.Name, "_")
                       If tt > 0 Then
                           r = Range("a" & Rows.Count).End(xlUp).Row
                             If r = 1 And Cells(1, 1) = "" Then
                              a = 1
                              Else
                              a = r + 1
                              End If
                            Cells(a, 1) = "'" & Left(subfd.Name, tt - 1)
                       End If
                End If
        GetSubFolder (subfd)
Next
End Sub

yooha

不提示保存