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

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path & \ '你的文本文件夹 With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem .Filename = \

.SearchSubFolders = True '同时也搜索子文件夹 If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

ReDim myfile(1 To n) As String For i = 1 To n

myfile(i) = .FoundFiles(i) Filename = myfile(i)

aa = InStrRev(Filename, \

nm = Right(Filename, Len(Filename) - aa) nm = Left(nm, Len(nm) - 4)

ActiveWorkbook.Worksheets.Add '把文本文件导入Excel新表 With ActiveSheet.QueryTables.Add(Connection:= _ \ .Refresh BackgroundQuery:=False End With

ActiveSheet.Name = nm Columns(\

Selection.TextToColumns Destination:=Range(\Space:=True, FieldInfo _

:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True [a1].Select Next Else

MsgBox \该文件夹里没有任何文件\ End If End With

Set myFs = Nothing End Sub

17，批量删除同文件夹里指定工作簿文件，

‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=87719&star=1#1101674 Sub plsc0119()

'批量删除指定的文件

Dim myFs As FileSearch

Dim myPath As String, Filename$

Dim i As Long, n As Long, myFile Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path '你的文本文件夹 With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeNoteItem .Filename = \

If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

ReDim myFile(1 To n) As String For i = 1 To n

myFile(i) = .FoundFiles(i)

If InStr(myFile(i), \一月\> 0 Or InStr(myFile(i), \二月\> 0 Or InStr(myFile(i), \三月\ Kill myFile(i) End If Next End If End With End Sub

18，统计文件夹里子文件夹名及所有的文件名

‘http://club.excelhome.net/viewthread.php?tid=393673&page=1&extra=page=1 ‘示例.rar Sub wjjm() '文件夹名

Dim fso, f, fc, myPath$, i%, myFol

Set fso = CreateObject(\ myPath = ThisWorkbook.path Set f = fso.GetFolder(myPath) Set fc = f.SubFolders For Each myFol In fc i = i + 1

Cells(i, 1) = myFol.Name Next

Set fso = Nothing End Sub

Sub wjjm()

'同目录下文件名（Files对象） Dim fso, f, fc, myPath$, i%, myFol

Set fso = CreateObject(\ myPath = ThisWorkbook.Path Set f = fso.GetFolder(myPath) Set fc = f.Files

For Each myFol In fc

If Right(myFol.Name, 3) = \ i = i + 1

Cells(i, 1) = myFol.Name End If Next

Set fso = Nothing End Sub

19，对文件夹里没有后缀名的文件加”.txt”后缀

‘2009-5-4 EP Sub tjwjjwj() '统计文件夹文件

Dim myFs As FileSearch Dim myPath As String Dim i As Long, n As Long

Set myFs = Application.FileSearch myPath = ThisWorkbook.path With myFs .NewSearch

.LookIn = myPath

.SearchSubFolders = True

If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

MsgBox \该文件夹里有\个文件\ ReDim myfile(1 To n) As String For i = 1 To n

myfile(i) = .FoundFiles(i)

aa = InStrRev(myfile(i), \

nm = Right(Myfile(i), Len(Myfile(i)) - aa) ‘nm = Left(nm, Len(nm) - 4) Cells(i, 1) = nm Next Else

MsgBox \该文件夹里没有任何文件\ End If End With

Set myFs = Nothing

End Sub

Sub tjwjjwj() '统计文件夹文件

Dim myFs As FileSearch Dim myPath As String Dim i As Long, n As Long

Set myFs = Application.FileSearch myPath = ThisWorkbook.Path With myFs

.NewSearch

.LookIn = myPath

.SearchSubFolders = True

If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

MsgBox \该文件夹里有\个文件\ ReDim Myfile(1 To n) As String For i = 1 To n

Myfile(i) = .FoundFiles(i) aa = InStrRev(Myfile(i), \

nm = Right(Myfile(i), Len(Myfile(i)) - aa) If InStr(nm, \

OldName = myPath & nm '原文件名

NewName = myPath & nm & \ '新文件名 Name OldName As NewName End If Next Else

MsgBox \该文件夹里没有任何文件\ End If End With

Set myFs = Nothing End Sub

20，搜索文件夹里照片插入指定的单元格

‘http://www.excelpx.com/dispbbs.asp?boardid=5&id=109767&star=1#1473386 Sub 图片归档0521()

Dim myFile, nn&, bh$, r1 Dim myFs As FileSearch Dim myPath As String

Dim i As Long, n As Long, m&, flnm$

Set myFs = Application.FileSearch

myPath = ThisWorkbook.Path & \ '指定文件夹 With myFs

.NewSearch

.LookIn = myPath

.FileType = msoFileTypeAllFiles '所有所有类型的文件 .Filename = \

If .Execute(SortBy:=msoSortByFileName) > 0 Then n = .FoundFiles.Count

ReDim myFile(1 To n) As String For i = 1 To n