【原】VBA批量提取文件夹名称

标题：批量提取文件夹名至EXCEL中的VBA代码

在实际工作中，有时需要把某个文件夹下的批量文件夹提取到EXCEL中，逐个粘贴夹名费时费力，写一段VBA代码可一键提取全部夹名至EXCEL中

功能：一键批量提取文件夹名至EXCEL中

运行环境：要求EXCEL支持VBA

运行效果如下：

以下为VBA代码

'************************************************************

Sub 提取本EXCEL同路径文件夹名称()

' '以下 清已提的文件夹名

   Sheets("1名称目录处理").Select '清空工作表“1名称目录处理”中B3:B110区原内容，以清除上一次运行时产生的无用夹名

    ActiveWindow.SmallScroll Down:=-12

    Range("B3:B110").Select

    Selection.ClearContents

'以下 自动提取文件夹名

Dim fs As Object

n = 3 '从第3行始，写入

Set fs = CreateObject("Scripting.FileSystemObject")

Set f = fs.getfolder(Sheets("1名称目录处理").Cells(1, 2)) '调取单元格B1中由公式自动生成的文件夹路径。（可在该单元格输入公式=LEFT(MID(CELL("filename",A1),1,SEARCH("[",CELL("filename",A1))-1),LEN(MID(CELL("filename",A1),1,SEARCH("[",CELL("filename",A1))-1))-1)'自动调用本EXCEL路径）

'也可直接输入绝对地址，（形如：“C:\Documents and Settings\Administrator\桌面\批提文件夹名”），读者可根据需要自行更改路径名称

For Each fd In f.subfolders

Cells(n, 2) = fd.Name 'Cells(n, 2)中n为行数，2为列数

n = n + 1

Next

Set f = Nothing

Set fs = Nothing

    Range("B4").Select

    ActiveWorkbook.Save

End Sub

'*****代码完**********************************************