Страницы: 1
RSS
Конвертировать пакетно xls в xlsx
 
Добрый день!
Мне необходимо было выполнить задачу по конвертации xls в xlsx в папке.
На просторах интернета, нашел вот такой макрос.
Код
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


Все отлично работает. Но мне необходимо чтобы я не выбирал папку в диалоговом окне, а путь к папке брался из ячейки А1.
 
evgeniygeo,
замените код
Код
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
на
Код
strPath =range("A1").value
If Right(strPath, 1) <> "\" Then strPath = strPath + "\"
Изменено: ivanok_v2 - 10.10.2018 15:58:48
 
У Вас тема называется Конвертировать пакетно xls в xlsx
Цитата
evgeniygeo написал:
Мне необходимо было выполнить задачу по конвертации xls в xlsx в папке.На просторах интернета, нашел вот такой макрос.
Цитата
evgeniygeo написал:
Все отлично работает
Исходя из этого вы сами решили проблему. А вот прописать путь не выбором папки а из конкретной ячейки это уже совсем другой вопрос. Вопрос по сути не сложный, но придумывать название самому , что-то нет времени.
Изменено: Nordheim - 10.10.2018 16:02:56
"Все гениальное просто, а все простое гениально!!!"
Страницы: 1
Наверх