VBA批量获取文件夹和文件名

VBA批量获取文件夹和文件名!!

Sub 获取任意文件夹文件名()

On Error GoTo err

Dim arr()

'默认打开目录；这里是桌面

With Application.FileDialog(msoFileDialogFolderPicker)

.InitialFileName = "C:\Users\" & Environ("username") & "\Desktop\"

If .Show = True Then Path = .SelectedItems(1) & "\"

End With

If Path = "" Then Exit Sub

'判断文件夹是否存在

MyName = Dir(Path, vbDirectory) '

Do

If MyName <> "." And MyName <> ".." Then

n = n + 1

ReDim Preserve arr(1 To n)

'文件夹用<>表示

arr(n) = IIf((GetAttr(Path & MyName) And vbDirectory) = vbDirectory, "<" & MyName & ">", MyName)

End If

MyName = Dir

Loop While MyName <> ""

'文件名写入单元格

With ActiveSheet

ro1 = IIf(.[A1] = "", 1, .Cells(55555, 1).End(3).Row + 1)

.Range("A" & ro1).Resize(n, 1) = WorksheetFunction.Transpose(arr)

ro2 = .Cells(55555, 1).End(3).Row

.Range("A" & ro1 & ":A" & ro2).Sort Key1:=.Range("A" & ro1), Order1:=xlAscending, Header:=xlGuess, _

OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod :=xlPinYin, DataOption1:=xlSortNormal

End With

err:

End Sub