分享

Excel xls与xlsx互转代码

 leexingyuan5 2017-03-24
不能发附件,自己建窗体
代码如下
VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} myCover
   Caption         =   "EXCLE批量转换格式"
   ClientHeight    =   4200
   ClientLeft      =   45
   ClientTop       =   435
   ClientWidth     =   4785
   OleObjectBlob   =   "myCover.frx":0000
   StartUpPosition =   1  '所有者中心
End
Attribute VB_Name = "myCover"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub CommandButton1_Click()
Dim myFiles
Dim myDirS, myDirO As String
Dim i As Long

If Application.Version = "11.0" Then
MsgBox ("老大,Excel2003不能打开高版本文件,请在07以上版本进行转换!")
Exit Sub
End If
If TextBox1.Value = "" Then
MsgBox ("老大,你没有指定路径,让我转空气啊?")
Exit Sub
ElseIf Dir(TextBox1.Value, vbDirectory) = vbNullString Then
MsgBox ("老大,你确定源文件路径真的存在?")
Exit Sub
End If

If TextBox2.Value = "" Then TextBox2.Value = TextBox1.Value
'处理路径
If Right(TextBox1.Value, 1) = "\" Then TextBox1.Value = Left(TextBox1.Value, Len(TextBox1.Value) - 1)
If Right(TextBox2.Value, 1) = "\" Then TextBox2.Value = Left(TextBox2.Value, Len(TextBox2.Value) - 1)


myDirS = TextBox1.Value
myDirO = TextBox2.Value
'目标路径不存在时先建立
If Dir(myDirO, vbDirectory) = "" Then MkDir myDirO

On Error Resume Next
Application.ScreenUpdating = True
Application.DisplayAlerts = False
If OptionButton1.Value = True Then
'07-13格式转03格式
myFiles = Dir(myDirS & "\*.xlsx")
Do While myFiles <> ""
Workbooks.Open Filename:=myDirS & "\" & myFiles
ActiveWorkbook.SaveAs Filename:= _
myDirO & "\" & Left(myFiles, Len(myFiles) - 1), FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
'删除源文件
If CheckBox1.Value = False Then Kill myDirS & "\" & myFiles
i = i + 1
myFiles = Dir
DoEvents
Loop
MsgBox "全部转换完毕,共转换文件 " & i & "个"
'03格式转07-13格式
Else
myFiles = Dir(myDirS & "\*.xls")
Do While myFiles <> ""
If Right(myFiles, 1) = "x" Then GoTo NF
Workbooks.Open Filename:=myDirS & "\" & myFiles
ActiveWorkbook.SaveAs Filename:= _
myDirO & "\" & myFiles & "x", FileFormat:=xlOpenXMLWorkbook, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
ActiveWindow.Close
i = i + 1
'删除源文件
If CheckBox1.Value = False Then Kill myDirS & "\" & myFiles
NF:
myFiles = Dir
DoEvents
Loop
MsgBox "全部转换完毕,共转换文件 " & i & "个"
End If

End Sub

Private Sub CommandButton2_Click()
Unload Me
End Sub

' 窗体初始化
Private Sub UserForm_Initialize()
TextBox1.Value = ActiveWorkbook.Path
    TextBox1.SetFocus
End Sub

    本站是提供个人知识管理的网络存储空间,所有内容均由用户发布,不代表本站观点。请注意甄别内容中的联系方式、诱导购买等信息,谨防诈骗。如发现有害或侵权内容,请点击一键举报。
    转藏 分享 献花(0

    0条评论

    发表

    请遵守用户 评论公约

    类似文章 更多