Excel VBA - 文本文件和文件夹操作实例集锦(15)

With ActiveWorkbook

Arr = .ActiveSheet.Range(\

.ActiveSheet.[B65536].End(3)) Arr(1, 1) = Split(ThisWorkb _

ook.Path, \\& \ .Close 0 End With

[A65536].End(3)(2).Resize(1, UBound(Arr)) = Application.Transpose(Arr) End If Next End Sub

37，提取文件夹名（Dir）by:cflood

‘http://club.excelhome.net/thread-627454-1-1.html Private Sub CommandButton1_Click() fp = ThisWorkbook.Path & \ fn = Dir(fp, vbDirectory) i = 1

[e2:e65536].ClearContents Do While fn <> \

If fn <> \

If (GetAttr(ThisWorkbook.Path & \& fn) And vbDirectory Then ‘如果不要这一判断，即为提取文件名

i = i + 1

Cells(i, 5).Value = fn end if

End If fn = Dir Loop End Sub

vbDirectory) = 38，VBA同时调用FSO、WScript、DOS语言的综合应用by:罗刚君

‘http://www.exceltip.net/viewthread.php?tid=7430&fromuid=37860&extra=page=1&filter=type&typeid=6

Sub 获取C盘以外所有磁盘的文件夹目录()

Dim FileSys As Object, Drv As Object, Letter As String

Set FileSys = CreateObject(\ '引用FSO对象 On Error Resume Next '防错

For Each Drv In FileSys.Drives '遍历所有磁盘

If Drv.IsReady Then '如果磁盘已准备好（主要针对光盘或者虚拟盘）

If Drv.DriveLetter <> \ '如果卷标不是C，那么将所有卷标合并 End If Next Drv

Dim Str As String, objShell As Object

Set objShell = CreateObject(\ '引用WScript对象

Set Do**ec = objShell.Exec(\ '引用DOS命令提取文件夹目录

Str = Do**ec.StdOut.ReadAll '将返回的值赋与变量Str

'将变量Str的值以换行符作为分隔符，将它转换成数组并写入到工作表中

[a1].Resize(UBound(Split(Str, Chr(10))) + 1, 1) = WorksheetFunction.Transpose(Split(Str, Chr(10)))

Set FileSys = Nothing '释放变量 Set Do**ec = Nothing Set objShell = Nothing End Sub

37，提取D盘所有文件夹名（FSO）by: 罗刚君

Sub 将D盘所有文件夹名罗列在A列() For Each Floder1 CreateObject(\ n = n + 1

Cells(n, 1) = Floder1.Name Next End Sub

In

38，提取D盘指定文件夹所有文件名（Dir）

‘http://club.excelhome.net/viewthread.php?tid=629785&pid=4260716&page=1&extra=page=1

Private Sub CommandButton1_Click() fp = \ fn = Dir(fp) i = 1

[b2:b65536].ClearContents Do While fn <> \ i = i + 1

Cells(i, 2).Value = fn fn = Dir Loop End Sub

39，提取D盘所有文件夹名和指定文件夹所有文件名（Dir） by:老朽 可用于2007、2010版

‘http://club.excelhome.net/thread-355569-1-3.html Sub Test() '使用双字典，旨在提高速度

Dim MyName, Dic, Did, I, T, F, TT, MyFileName T = Time

Set Dic = CreateObject(\'创建一个字典对象 Set Did = CreateObject(\ Dic.Add (\ I = 0

Do While I < Dic.Count

Ke = Dic.keys '开始遍历字典

MyName = Dir(Ke(I), vbDirectory) '查找目录 Do While MyName <> \

If MyName <> \

If (GetAttr(Ke(I) & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录

Dic.Add (Ke(I) & MyName & \'就往字典中添加这个次级目录名作为一个条目

End If End If