Sub 提取文件名()
Set Fold = CreateObject("shell.application").BrowseForFolder(0, "请选择存放数据的文件夹：", 0, "") '选择文件夹
If Fold Is Nothing Then Exit Sub '如果没选择文件夹就退出循环
mp = Fold.Items.Item.Path & "\" '路径
n = 1
mf = Dir(mp & "\*.*") '文件名
Do While mf <> "" And mf <> ThisWorkbook.Name '遍历
Cells(1, 1) = "提取文件名显示如下"
k = Application.Find(".", mf) - 1
Cells(n + 1, 1) = Left(mf, k) '数据写入
mf = Dir '找寻下一个文件
n = n + 1 '计数、累加
Loop
ActiveWorkbook.Save '保存

End Sub

怎么改成循环读取

楼主 VBA问题，请悬赏高一点哦