Всем привет! Задача такая: Есть 300 файлов в 2х форматах "xlsx" и "xls", хочу скушать их через PQ, ессесено надо в один формат перевести. Нашел отличный макрос, рабочий ТЫЦ (если не ошибаюсь автор - Дмитрий(The_Prist) Щербаков) Все файлы перевел в "xlsx" НО! чуть ранее я работал с 70 файлами с хорошим объёмом, в PQ приходится использовать алгоритм в том числе с абсолютной ссылками (без них ни как) - выгрузка занимала от 4 часов (Оо), я используя совет от Павла в книге, перевел (в ручную) файлы в формат "CSV" - результат: запрос сократился до 2х часов
Так вот, можно ли используя этот макрос, все файлы пересохранить в "CSV" формат? Если да, то как его изменить?
В жизни нет ничего невозможного! Есть только недостаток знаний и умений.
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄
А если в сохраняемых файлах листов больше, чем один, то измените код следующим образом:
Код
'---------------------------------------------------------------------------------------
' 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
Во всех делах очень полезно периодически ставить знак вопроса к тому, что вы с давних пор считали не требующим доказательств (Бертран Рассел) ►Благодарности сюда◄