[已解决]save as 问题

sparkguo

请问各位老师，如何将XLSX批量调整为XLS,附件中有代码，但是总是出错，所以来论坛请老师帮忙
各位老师  周末愉快

最佳答案

月排行榜 / 总排行榜

wp8680

2015-10-18 11:12

1. Sub xqoa2()    '如有疑问，可询OFFICE之家-2群 39212411
   
2.     Dim Arr(1 To 10000), myPath$, myFile$, AK As Workbook, i As Integer, j&
   
3.     Set ShApp = CreateObject("Shell.Application")
   
4.     '数据区文件夹上层文件夹中存在不能识别的符号也会出错，比如xlsx?xls文件夹，所以我把数据区单独移到外面常规的文件夹下，就正确了。
   
5.     Set Path1 = ShApp.BrowseForFolder(0, "请选择文件夹", 0, 0)
   
6.     If Path1 Is Nothing Then Exit Sub
   
7.     myPath = Path1.items.Item.Path & ""
   
8.     myFile = Dir(myPath & "*.xlsx")    '原来这里多一个/符号，导致错误。
   
9.     '    On Error Resume Next
   
10.     Application.DisplayAlerts = False    '表示禁止显示提示和警告消息
    
11.     Do While myFile <> ""
    
12.         If myFile Like "*.xlsx" Then
    
13.             i = i + 1
    
14.             Arr(i) = myPath & myFile
    
15.         End If
    
16.         myFile = Dir
    
17.     Loop
    
18.     If i Then
    
19.         Application.ScreenUpdating = True
    
20.         For j = 1 To i
    
21.             Workbooks.Open Arr(j)
    
22.             ActiveWorkbook.SaveAs Filename:=Left(Arr(j), Len(Arr(j)) - 1), FileFormat:=xlExcel8, _
    
23.                                   Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    
24.                                   CreateBackup:=False
    
25.             '此处原来的文件名命名也是错的，因为已经循环完了，就myFile变量中的值变化了
    
26.             ActiveWorkbook.Close
    
27.         Next j
    
28.         Application.ScreenUpdating = False
    
29.         MsgBox "全部转换完毕，共转换文件 " & i & "个"
    
30.     End If
    
31.     Erase Arr
    
32.     Application.DisplayAlerts = True    '表示显示提示和警告消息
    
33. End Sub
    

复制代码

跳转到最佳答案楼层

wp8680

1. Sub xqoa2()    '如有疑问，可询OFFICE之家-2群 39212411
   
2.     Dim Arr(1 To 10000), myPath$, myFile$, AK As Workbook, i As Integer, j&
   
3.     Set ShApp = CreateObject("Shell.Application")
   
4.     '数据区文件夹上层文件夹中存在不能识别的符号也会出错，比如xlsx?xls文件夹，所以我把数据区单独移到外面常规的文件夹下，就正确了。
   
5.     Set Path1 = ShApp.BrowseForFolder(0, "请选择文件夹", 0, 0)
   
6.     If Path1 Is Nothing Then Exit Sub
   
7.     myPath = Path1.items.Item.Path & ""
   
8.     myFile = Dir(myPath & "*.xlsx")    '原来这里多一个/符号，导致错误。
   
9.     '    On Error Resume Next
   
10.     Application.DisplayAlerts = False    '表示禁止显示提示和警告消息
    
11.     Do While myFile <> ""
    
12.         If myFile Like "*.xlsx" Then
    
13.             i = i + 1
    
14.             Arr(i) = myPath & myFile
    
15.         End If
    
16.         myFile = Dir
    
17.     Loop
    
18.     If i Then
    
19.         Application.ScreenUpdating = True
    
20.         For j = 1 To i
    
21.             Workbooks.Open Arr(j)
    
22.             ActiveWorkbook.SaveAs Filename:=Left(Arr(j), Len(Arr(j)) - 1), FileFormat:=xlExcel8, _
    
23.                                   Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
    
24.                                   CreateBackup:=False
    
25.             '此处原来的文件名命名也是错的，因为已经循环完了，就myFile变量中的值变化了
    
26.             ActiveWorkbook.Close
    
27.         Next j
    
28.         Application.ScreenUpdating = False
    
29.         MsgBox "全部转换完毕，共转换文件 " & i & "个"
    
30.     End If
    
31.     Erase Arr
    
32.     Application.DisplayAlerts = True    '表示显示提示和警告消息
    
33. End Sub
    

复制代码

hysys32

Sub xqoa2() '不知道怎么修改代码，请老师修改
    Dim Arr(1 To 10000), myPath$, myFile$, AK As Workbook, i As Integer, j&
    Set ShApp = CreateObject("Shell.Application")
    Set Path1 = ShApp.BrowseForFolder(0, "请选择文件夹", 0, 0)
    If Path1 Is Nothing Then Exit Sub
    myPath = Path1.items.Item.Path & "\"
    myFile = Dir(myPath & "\*.xlsx")
    On Error Resume Next
    Do While myFile <> ""
        If myFile Like "*.xlsx" Then
           i = i + 1
           Arr(i) = myPath & myFile
        End If
        myFile = Dir
    Loop
    If i Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        myPath = ThisWorkbook.Path & "\结果\"
        
        For j = 1 To i
        myFile = Split(Arr(j), "\")(UBound(Split(Arr(j), "\")))
            Workbooks.Open Arr(j)
            ActiveWorkbook.SaveAs Filename:= _
            myPath & Left(myFile, Len(myFile) - 1), FileFormat:=xlExcel8, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False
            ActiveWorkbook.Close
        Next j
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        MsgBox "全部转换完毕，共转换文件 " & i & "个"
    End If
    Erase Arr
End Sub

sparkguo

hysys32 发表于 2015-10-18 11:22
Sub xqoa2() '不知道怎么修改代码，请老师修改
    Dim Arr(1 To 10000), myPath$, myFile$, AK As Workbo ...

myFile = Split(Arr(j), "\")(UBound(Split(Arr(j), "\")))    是什么意思？

hysys32

sparkguo 发表于 2015-10-18 16:33
myFile = Split(Arr(j), "\")(UBound(Split(Arr(j), "\")))    是什么意思？

获取工作表的名称

hysys32

获取工作表的名称