Excel Macro для преобразования xlsx в xls

Question

У меня есть куча файлов в папке, все они в формате xlsx, мне нужно преобразовать их в формат xls. Это будет сделано на ежедневной основе.

Мне нужен макрос, который будет вращаться вокруг папки и преобразовывать файл в xls из xlsx без изменения имени файла.?

Вот макрос, я использую для цикла

Sub ProcessFiles() 
Dim Filename, Pathname As String 
Dim wb As Workbook 

Pathname = ActiveWorkbook.Path & "C:\Users\myfolder1\Desktop\myfolder\Macro\" 
Filename = Dir(Pathname & "*.xls") 
Do While Filename <> "" 
    Set wb = Workbooks.Open(Pathname & Filename) 
    DoWork wb 
    wb.Close SaveChanges:=True 
    Filename = Dir() 
Loop 
End Sub 

Answer 1

Что вам не хватает в том, что вместо вызова wb.Close SaveChanges=True, чтобы сохранить файл в другом формате, вам нужно позвонить wb.SaveAs с новым файлом format и имя.

Вы сказали, что хотите их конвертировать без изменения имени файла, но я подозреваю, что вы действительно хотите сохранить их с тем же именем базового файла, но с расширением .xls. Так что если книга называется book1.xlsx, вы хотите сохранить ее как book1.xls. Чтобы рассчитать новое имя, вы можете сделать простой Replace() по старому имени, заменив расширение .xlsx.xls.

Вы также можете отключить проверку совместимости, установив wb.CheckCompatibility и подавить оповещения и сообщения, установив Application.DisplayAlerts.

Sub ProcessFiles() 
Dim Filename, Pathname, saveFileName As String 
Dim wb As Workbook 
Dim initialDisplayAlerts As Boolean 

Pathname = "<insert_path_here>" ' Needs to have a trailing \ 
Filename = Dir(Pathname & "*.xlsx") 
initialDisplayAlerts = Application.DisplayAlerts 
Application.DisplayAlerts = False 
Do While Filename <> "" 
    Set wb = Workbooks.Open(Filename:=Pathname & Filename, _ 
          UpdateLinks:=False) 
    wb.CheckCompatibility = False 
    saveFileName = Replace(Filename, ".xlsx", ".xls") 

    wb.SaveAs Filename:=Pathname & saveFileName, _ 
       FileFormat:=xlExcel8, Password:="", WriteResPassword:="", _ 
       ReadOnlyRecommended:=False, CreateBackup:=False 

    wb.Close SaveChanges:=False 
    Filename = Dir() 
Loop 
Application.DisplayAlerts = initialDisplayAlerts 
End Sub 

Answer 2

Sub SaveAllAsXLSX() 
Dim strFilename As String 
Dim strDocName As String 
Dim strPath As String 
Dim wbk As Workbook 
Dim fDialog As FileDialog 
Dim intPos As Integer 
Dim strPassword As String 
Dim strWritePassword As String 
Dim varA As String 
Dim varB As String 
Dim colFiles As New Collection 
Dim vFile As Variant 
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker) 
With fDialog 
    .Title = "Select folder and click OK" 
    .AllowMultiSelect = True 
    .InitialView = msoFileDialogViewList 
    If .Show <> -1 Then 
     MsgBox "Cancelled By User", , "List Folder Contents" 
     Exit Sub 
    End If 
    strPath = fDialog.SelectedItems.Item(1) 
    If Right(strPath, 1) <> "\" Then strPath = strPath + "\" 
End With 
If Left(strPath, 1) = Chr(34) Then 
    strPath = Mid(strPath, 2, Len(strPath) - 2) 
End If 
Set obj = CreateObject("Scripting.FileSystemObject") 
RecursiveDir colFiles, strPath, "*.xls", True 
For Each vFile In colFiles 
     Debug.Print vFile 
    strFilename = vFile 
    varA = Right(strFilename, 3) 
    If (varA = "xls" Or varA = "XLS") Then 
    Set wbk = Workbooks.Open(Filename:=strFilename) 
     If wbk.HasVBProject Then 
       wbk.SaveAs Filename:=strFilename & "m", FileFormat:=xlOpenXMLWorkbookMacroEnabled 
      Else 
       wbk.SaveAs Filename:=strFilename & "x", FileFormat:=xlOpenXMLWorkbook 
      End If 
      wbk.Close SaveChanges:=False 
      obj.DeleteFile (strFilename) 
    End If 
Next vFile 

End Sub 
Public Function RecursiveDir(colFiles As Collection, _ 
          strFolder As String, _ 
          strFileSpec As String, _ 
          bIncludeSubfolders As Boolean) 

    Dim strTemp As String 
    Dim colFolders As New Collection 
    Dim vFolderName As Variant 

    'Add files in strFolder matching strFileSpec to colFiles 
    strFolder = TrailingSlash(strFolder) 
    strTemp = Dir(strFolder & strFileSpec) 
    Do While strTemp <> vbNullString 
     colFiles.Add strFolder & strTemp 
     strTemp = Dir 
    Loop 

    If bIncludeSubfolders Then 
     'Fill colFolders with list of subdirectories of strFolder 
     strTemp = Dir(strFolder, vbDirectory) 
     Do While strTemp <> vbNullString 
      If (strTemp <> ".") And (strTemp <> "..") Then 
       If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then 
        colFolders.Add strTemp 
       End If 
      End If 
      strTemp = Dir 
     Loop 

     'Call RecursiveDir for each subfolder in colFolders 
     For Each vFolderName In colFolders 
      Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True) 
     Next vFolderName 
    End If 

End Function 
Public Function TrailingSlash(strFolder As String) As String 
    If Len(strFolder) > 0 Then 
     If Right(strFolder, 1) = "\" Then 
      TrailingSlash = strFolder 
     Else 
      TrailingSlash = strFolder & "\" 
     End If 
    End If 
End Function