'***********访问当前文件夹下所有子文件夹及文件,
Dim iFile(1 To 100000) As String
Dim count As Integer
Public k As Integer
Sub CommandButton1_Click()
iPath = ThisWorkbook.Path
On Error Resume Next
count = 0
k = 0
Sheet1.Cells(3, 5) = k
Sheet1.Cells(6, 5) = ""
zdir iPath
For i = 1 To count
If iFile(i) Like "*.xls" And iFile(i) <> ThisWorkbook.FullName Then
MyFile = iFile(i)
FilePath = Replace(MyFile, ".xls", ".xlsx")
If Dir(FilePath, 16) = Empty Then
Set WBookOther = Workbooks.Open(MyFile)
Application.ScreenUpdating = False
ActiveWorkbook.SaveAs Filename:=FilePath, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
WBookOther.Close SaveChanges:=False '解决不能close 文件问题
Application.ScreenUpdating = True
k = k + 1
Sheet1.Cells(3, 5) = k
Sheet1.Cells(6, 5) = MyFile
DoEvents
End If
End If
Next
MsgBox ("--转换完成--")
End Sub
Sub zdir(p) '访问当前文件夹下所有子文件夹及文件
Set fs = CreateObject("scripting.filesystemobject")
For Each f In fs.GetFolder(p).Files
If f <> ThisWorkbook.FullName Then count = count + 1: iFile(count) = f
Next
For Each m In fs.GetFolder(p).SubFolders
zdir m
Next
End Sub
Private Sub 开始删除xls文件_Click()
iPath = ThisWorkbook.Path
On Error Resume Next
count = 0
k = 0
Sheet1.Cells(3, 5) = k
Sheet1.Cells(6, 5) = ""
zdir iPath
For i = 1 To count
If iFile(i) Like "*.xls" And iFile(i) <> ThisWorkbook.FullName Then
MyFile = iFile(i)
FilePath = Replace(MyFile, ".xls", ".xlsx")
If Dir(FilePath, 16) <> Empty Then
Kill MyFile
k = k + 1
Sheet1.Cells(3, 5) = k
Sheet1.Cells(6, 5) = MyFile
DoEvents
End If
End If
Next
MsgBox ("--删除完成--")
End Sub
Private Sub 移动xls文件_Click()
iPath = ThisWorkbook.Path
Dim oFso As Object
On Error Resume Next
count = 0
k = 0
Sheet1.Cells(3, 5) = k
Sheet1.Cells(6, 5) = ""
Dim strFolder As String
'差异:msoFileDialogFolderPicker
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "选择目标文件夹"
.InitialFileName = ThisWorkbook.Path
If .Show Then
strFolder = .SelectedItems(1)
End If
End With
Sheet1.Cells(14, 5) = strFolder
If strFolder = "" Then
MsgBox ("--程序终止--")
Exit Sub
End If
zdir iPath
Set oFso = CreateObject("Scripting.FileSystemObject")
For i = 1 To count
If iFile(i) Like "*.xls" And iFile(i) <> ThisWorkbook.FullName Then
MyFile = iFile(i)
FilePath = Replace(MyFile, ".xls", ".xlsx")
Filename = Dir(MyFile, 16)
If Dir(FilePath, 16) <> Empty Then
oFso.movefile MyFile, strFolder + "\" + Filename
k = k + 1
Sheet1.Cells(3, 5) = k
Sheet1.Cells(6, 5) = MyFile
DoEvents
End If
End If
Next
MsgBox ("--移动完成--")
End Sub
界面: