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


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

界面:

 

  • 1
    点赞
  • 1
    收藏
    觉得还不错? 一键收藏
  • 0
    评论

“相关推荐”对你有帮助么?

  • 非常没帮助
  • 没帮助
  • 一般
  • 有帮助
  • 非常有帮助
提交
评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包
实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值