Страницы: 1
RSS
VBA: Массовое пересохранения файлов в другой формат
 
Всем привет!
Задача такая: Есть 300 файлов в 2х форматах "xlsx" и "xls", хочу скушать их через PQ, ессесено надо в один формат перевести.
Нашел отличный макрос, рабочий ТЫЦ (если не ошибаюсь автор - Дмитрий(The_Prist) Щербаков)
Все файлы перевел в "xlsx"
НО! чуть ранее я работал с 70 файлами с хорошим объёмом, в PQ приходится использовать алгоритм в том числе с абсолютной ссылками (без них ни как) - выгрузка занимала от 4 часов (Оо), я используя совет от Павла в книге, перевел (в ручную) файлы в формат "CSV" - результат: запрос сократился до 2х часов :)

Так вот, можно ли используя этот макрос, все файлы пересохранить в "CSV" формат? Если да, то как его изменить?  
В жизни нет ничего невозможного! Есть только недостаток знаний и умений.
 
Видимо, достаточно вставить строку
Код
Case "csv": lFileFormat = 24
 
Александр, здравствуйте!
Ссылка из приёмов
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
 
А если в сохраняемых файлах листов больше, чем один, то измените код следующим образом:
Код
'---------------------------------------------------------------------------------------
' Author : The_Prist(Щербаков Дмитрий)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          http://www.excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------

Sub SaveAs_Mass()
    Dim sFolder As String, sFiles As String, sNonEx As String, sNewEx As String
    Dim wb As Workbook
    Dim lPos As Long, lFileFormat As Long, IsDelOriginal As Boolean
 
    'указываем новый формат файлов
    sNewEx = InputBox("Укажите новое расширение для файлов:", "www.excel-vba.ru", "xlsx")
    'определяем числовой код формата файлов
    Select Case sNewEx
        Case "xlt": lFileFormat = 17
        Case "xla": lFileFormat = 18
        Case "xlsb": lFileFormat = 50
        Case "xlsx": lFileFormat = 51
        Case "xlsm": lFileFormat = 52
        Case "xltm": lFileFormat = 53
        Case "xltx": lFileFormat = 54
        Case "xlam": lFileFormat = 55
        Case "xls": lFileFormat = 56
        Case "csv": lFileFormat = 24
        'если указанный формат не соответсвует ни одному из существующих
        Case Else
            MsgBox "Формат '" & sNewEx & "' не поддерживается", vbCritical, "www.excel-vba.ru"
            Exit Sub
    End Select
 
    '   если надо просматривать файлы в той же папке, что и файл с кодом:
    '       sFolder = ThisWorkbook.Path
    'диалог запроса выбора папки с файлами
    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = False Then Exit Sub
        sFolder = .SelectedItems(1)
    End With
    sFolder = sFolder & IIf(Right(sFolder, 1) = Application.PathSeparator, "", Application.PathSeparator)
    'запрашиваем - удалять ли исходные файлы после сохранения в новом формате
    IsDelOriginal = MsgBox("Удалять исходные файлы после пересохранения?", vbQuestion + vbYesNo, "www.excel-vba.ru") = vbYes
    'отключаем обновление экрана и показ системных сообщений
    Application.ScreenUpdating = 0
    Application.DisplayAlerts = 0
    Dim sh As Worksheet
    'просматриваем все файлы Excel в выбранной папке
    sFiles = Dir(sFolder & "*.xls*")
    Do While sFiles <> ""
        If sFiles <> ThisWorkbook.Name Then
            'получаем имя файла без расширения
            lPos = InStrRev(sFiles, ".")
            sNonEx = Mid(sFiles, 1, lPos)
            'открываем книгу
            Set wb = Application.Workbooks.Open(sFolder & sFiles, False)
            'сохраняем в новом формате и закрываем
            Select Case lFileFormat
            Case 24
                wb.Activate
                For Each sh In wb.Worksheets
                    sh.Select
                    wb.SaveAs sFolder & sNonEx & sh.Name & "." & sNewEx, lFileFormat
                Next
            Case Else
                wb.SaveAs sFolder & sNonEx & sNewEx, lFileFormat
            End Select
            wb.Close 0
            DoEvents
            'если надо удалить исходные файлы после преобразования
            If IsDelOriginal Then
                On Error Resume Next
                Kill sFolder & sFiles
                DoEvents
                On Error GoTo 0
            End If
        End If
        sFiles = Dir
    Loop
    'возвращаем обновление экрана и показ системных сообщений
    Application.ScreenUpdating = 1
    Application.DisplayAlerts = 1
    MsgBox "Файлы преобразованы", vbInformation, "www.excel-vba.ru"
End Sub
 
Спасибо, сработало!
Только использовал формат "6", а то 24 мне не знаком.  
В жизни нет ничего невозможного! Есть только недостаток знаний и умений.
 
Цитата
МатросНаЗебре написал:
А если в сохраняемых файлах листов больше
Часть книг имеет доп листы, но мне нужно только 1, в PQ загрузил пока все нормально.
В жизни нет ничего невозможного! Есть только недостаток знаний и умений.
 
Цитата
Александр: использовал формат "6", а то 24 мне не знаком
так да - обычно так и есть
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
Страницы: 1
Наверх