VBA excel文件xls批量转换为xlsx,文件移动，文件删除

最新推荐文章于 2024-04-13 19:06:39 发布

雨落星辰C

最新推荐文章于 2024-04-13 19:06:39 发布

阅读量541

点赞数 1

分类专栏： vba 文章标签： excel

本文链接：https://blog.csdn.net/qq_34276316/article/details/131575655

版权

vba 专栏收录该内容

2 篇文章 0 订阅

订阅专栏


'***********访问当前文件夹下所有子文件夹及文件,
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

界面：