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