vba 遍历一个文件夹（可浏览指定），子目录不需要遍历，然后把文件名和路径存入数组。
3个回答
展开全部
贴个VBS代码的吧，懒得改成VBA的了，主要部分应该是一样的。
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(MY_COMPUTER)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", OPTIONS, strPath)
If objFolder Is Nothing Then
Wscript.Quit
End If
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
Set ws=WScript.CreateObject("wscript.shell")
w=ws.CurrentDirectory
Set fso=WScript.CreateObject("scripting.filesystemobject")
Set fs=fso.GetFolder(objPath)
Set f=fs.SubFolders
set ie=wscript.createobject("internetexplorer.application","event_") '创建ie对象'
ie.menubar=0 '取消菜单栏'
ie.addressbar=0 '取消地址栏'
ie.toolbar=0 '取消工具栏'
ie.statusbar=0 '取消状态栏'
ie.width=600 '宽600'
ie.height=400 '高400'
ie.resizable=0 '不允许用户改变窗口大小'
ie.navigate "about:blank" '打开空白页面'
ie.left=fix((ie.document.parentwindow.screen.availwidth-ie.width)/2) '水平居中'
ie.top=fix((ie.document.parentwindow.screen.availheight-ie.height)/2) '垂直居中'
ie.visible=1 '窗口可见'
with ie.document '以下调用document.write方法，'
.write "<BODY>"
.write "Folder Size List"
.write "<table border="
.write "<TABLE>"
Dim FolderSize
on error resume next
For Each uu In f
If uu.Attributes<>22 then
.write "<TR>"
.write "<TD>" & uu.Path & "</TD>"
.write "<TD>" & CInt(uu.Size/1024/1024) & "MB" & "</TD>"
.write "</TR>"
End if
Next
.write "</TABLE>"
.write "</BODY>"
.write "</br>"
MsgBox "read finish"
End With
Const MY_COMPUTER = &H11&
Const WINDOW_HANDLE = 0
Const OPTIONS = 0
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(MY_COMPUTER)
Set objFolderItem = objFolder.Self
strPath = objFolderItem.Path
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(WINDOW_HANDLE, "Select a folder:", OPTIONS, strPath)
If objFolder Is Nothing Then
Wscript.Quit
End If
Set objFolderItem = objFolder.Self
objPath = objFolderItem.Path
Set ws=WScript.CreateObject("wscript.shell")
w=ws.CurrentDirectory
Set fso=WScript.CreateObject("scripting.filesystemobject")
Set fs=fso.GetFolder(objPath)
Set f=fs.SubFolders
set ie=wscript.createobject("internetexplorer.application","event_") '创建ie对象'
ie.menubar=0 '取消菜单栏'
ie.addressbar=0 '取消地址栏'
ie.toolbar=0 '取消工具栏'
ie.statusbar=0 '取消状态栏'
ie.width=600 '宽600'
ie.height=400 '高400'
ie.resizable=0 '不允许用户改变窗口大小'
ie.navigate "about:blank" '打开空白页面'
ie.left=fix((ie.document.parentwindow.screen.availwidth-ie.width)/2) '水平居中'
ie.top=fix((ie.document.parentwindow.screen.availheight-ie.height)/2) '垂直居中'
ie.visible=1 '窗口可见'
with ie.document '以下调用document.write方法，'
.write "<BODY>"
.write "Folder Size List"
.write "<table border="
.write "<TABLE>"
Dim FolderSize
on error resume next
For Each uu In f
If uu.Attributes<>22 then
.write "<TR>"
.write "<TD>" & uu.Path & "</TD>"
.write "<TD>" & CInt(uu.Size/1024/1024) & "MB" & "</TD>"
.write "</TR>"
End if
Next
.write "</TABLE>"
.write "</BODY>"
.write "</br>"
MsgBox "read finish"
End With
已赞过
已踩过<
评论
收起
你对这个回答的评价是？
展开全部
用dir函数，在循环中把dir返回的文件名赋给数组
本回答被网友采纳
已赞过
已踩过<
评论
收起
你对这个回答的评价是？
展开全部
With Application.FileSearch
.NewSearch
.LookIn = mainpath
.SearchSubFolders = True
.Filename = "*.*"
FileType = msoFileTypeAllFiles 'msoFileTypeExcelWorkbooks
jdjd = .Execute()
If .Execute() > 0 Then
For I = 1 To .FoundFiles.Count
On Error Resume Next
If Workbooks("CDMA_CDD_TOOLS").Sheets("tools").hssite.Value = True Then
Workbooks.OpenText Filename:=.FoundFiles(I), _
DataType:=xlDelimited, Space:=True, ConsecutiveDelimiter:=True
'Workbooks.OpenText Filename:=.FoundFiles(I), DataType:=xlDelimited, Space:=True, ConsecutiveDelimiter:=True
tnameB = ParseFileName(.FoundFiles(I))
Set WSB = Workbooks(tnameB)
Call FormatHsSite.formatsheets
tnamea = Trim(Mid(Cells(1.2), 4, 30))
scopyHS WSA, WSB, tnamea, tnameB
End If
dk = 1
If Workbooks("CDMA_CDD_TOOLS").Sheets("tools").ipsite.Value = True Then
Set WSB = Workbooks.Open(Filename:=.FoundFiles(I))
tnamea = ParseFileName(.FoundFiles(I))
tnameB = "Sheet0"
scopyIP WSA, WSB, tnamea, tnameB
wsbname = ""
End If
Application.StatusBar = "正在处理：第" & I & "个文件"
Application.ScreenUpdating = False
Next I
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
.NewSearch
.LookIn = mainpath
.SearchSubFolders = True
.Filename = "*.*"
FileType = msoFileTypeAllFiles 'msoFileTypeExcelWorkbooks
jdjd = .Execute()
If .Execute() > 0 Then
For I = 1 To .FoundFiles.Count
On Error Resume Next
If Workbooks("CDMA_CDD_TOOLS").Sheets("tools").hssite.Value = True Then
Workbooks.OpenText Filename:=.FoundFiles(I), _
DataType:=xlDelimited, Space:=True, ConsecutiveDelimiter:=True
'Workbooks.OpenText Filename:=.FoundFiles(I), DataType:=xlDelimited, Space:=True, ConsecutiveDelimiter:=True
tnameB = ParseFileName(.FoundFiles(I))
Set WSB = Workbooks(tnameB)
Call FormatHsSite.formatsheets
tnamea = Trim(Mid(Cells(1.2), 4, 30))
scopyHS WSA, WSB, tnamea, tnameB
End If
dk = 1
If Workbooks("CDMA_CDD_TOOLS").Sheets("tools").ipsite.Value = True Then
Set WSB = Workbooks.Open(Filename:=.FoundFiles(I))
tnamea = ParseFileName(.FoundFiles(I))
tnameB = "Sheet0"
scopyIP WSA, WSB, tnamea, tnameB
wsbname = ""
End If
Application.StatusBar = "正在处理：第" & I & "个文件"
Application.ScreenUpdating = False
Next I
Else
MsgBox "Folder " & sFolder & " contains no required files"
End If
已赞过
已踩过<
评论
收起
你对这个回答的评价是？
更多回答（1）
推荐律师服务：
若未解决您的问题，请您详细描述您的问题，通过百度律临进行免费专业咨询
