vba html 转化为 xlsx,Excel VBA将一个目录下的所有xls文件批量转换为xlsx文件

Option Explicit

Sub xlsTOxlsx()

Dim strFilePath As String, strFileName As String, strFileType As String

Dim aIndex As Long, arrFileName() As String, strNewName As String

'设置文件扩展名标识文件类型

strFileType = ".xls"

On Error Resume Next

'设置文件夹路径

strFilePath = CreateObject("shell.application").BrowseForFolder(0, "请选择文件夹", 0).self.Path

If Err <> 0 Or InStr(1, strFilePath, "::") > 0 Then

Err = 0

Exit Sub

End If

'开始搜索文件

strFileName = Dir(strFilePath & "*.*")

Do While strFileName <> ""

If LCase(Right(strFileName, Len(strFileType))) = LCase(strFileType) Then

ReDim Preserve arrFileName(aIndex)

arrFileName(aIndex) = strFileName

aIndex = aIndex + 1

'Debug.Print strFileName

End If

strFileName = Dir

DoEvents

Loop

If aIndex = 0 Then Exit Sub

Application.ScreenUpdating = False

Application.DisplayAlerts = False

For aIndex = LBound(arrFileName) To UBound(arrFileName)

strNewName = Mid(arrFileName(aIndex), 1, Len(arrFileName(aIndex)) - Len(strFileType)) & ".xlsx"

Workbooks.Open strFilePath & arrFileName(aIndex)

ActiveWorkbook.SaveAs Filename:=strFilePath & strNewName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

Workbooks(strNewName).Close False '关闭工作簿

Kill strFilePath & arrFileName(aIndex)

DoEvents

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

MsgBox "操作完成，共为您转换了 " & UBound(arrFileName) + 1 & " 个文件。", vbOKOnly, "完成"

End Sub