Домашняя страница Undo Do New Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Пакетное "Сохранить как" - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
Страница 1 из 11
Модератор форума: _Boroda_, Pelena, Manyasha, SLAVICK 
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Пакетное "Сохранить как" (Макросы/Sub)
Пакетное "Сохранить как"
Sancho Дата: Вторник, 15.03.2016, 14:14 | Сообщение № 1
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 3 ±
Замечаний: 0% ±

2007, 2010, 2013
Приветствую уважаемые.
Столкнулся с проблемой: нужно 8 тысяч файлов в одной папке в формате *.XLSM (с поддержкой макросов) "Сохранить как" в формате *.XLSX (без макросов). Можете помочь?
 
Ответить
СообщениеПриветствую уважаемые.
Столкнулся с проблемой: нужно 8 тысяч файлов в одной папке в формате *.XLSM (с поддержкой макросов) "Сохранить как" в формате *.XLSX (без макросов). Можете помочь?

Автор - Sancho
Дата добавления - 15.03.2016 в 14:14
Manyasha Дата: Вторник, 15.03.2016, 14:31 | Сообщение № 2
Группа: Модераторы
Ранг: Старожил
Сообщений: 1832
Репутация: 766 ±
Замечаний: 0% ±

Excel 2007, 2010
Sancho, для перебора файлов посмотрите готовое решение
Сохранить как
[vba]
Код
wb.SaveAs wb.Path & "\" & "111.xlsx", xlOpenXMLWorkbook
[/vba]


marinamorozova_box@mail.ru
ЯД: 410013299366744 WM: R193491431804
 
Ответить
СообщениеSancho, для перебора файлов посмотрите готовое решение
Сохранить как
[vba]
Код
wb.SaveAs wb.Path & "\" & "111.xlsx", xlOpenXMLWorkbook
[/vba]

Автор - Manyasha
Дата добавления - 15.03.2016 в 14:31
Karataev Дата: Вторник, 15.03.2016, 14:57 | Сообщение № 3
Группа: Проверенные
Ранг: Ветеран
Сообщений: 837
Репутация: 312 ±
Замечаний: 0% ±

Excel
Готовый макрос. Макрос создает новую папку рядом с папкой, в которой файлы. И в эту новую папку пересохраняет файлы.
[vba]
Код
Sub Изменить_формат_файлов()

    Dim strFolder As String, strFileName As String
    Dim strNewFolder As String, strNewFileName As String
    Dim wb As Workbook
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = 0 Then
            Exit Sub
        End If
        strFolder = .SelectedItems(1)
    End With
    
    strNewFolder = strFolder & "_" & Format(Now, "dd.mm.yyyy hh.mm.ss")
    MkDir strNewFolder
    
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    strFileName = Dir(strFolder & "\*.xlsm")
    Do While strFileName <> ""
        Set wb = Workbooks.Open(strFolder & "\" & strFileName)
        strNewFileName = Left(strFileName, InStrRev(strFileName, ".") - 1)
        strNewFileName = strNewFileName & ".xlsx"
        wb.SaveAs strNewFolder & "\" & strNewFileName, xlOpenXMLWorkbook
        wb.Close
        strFileName = Dir
    Loop
    
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]




Сообщение отредактировал Karataev - Вторник, 15.03.2016, 14:59
 
Ответить
СообщениеГотовый макрос. Макрос создает новую папку рядом с папкой, в которой файлы. И в эту новую папку пересохраняет файлы.
[vba]
Код
Sub Изменить_формат_файлов()

    Dim strFolder As String, strFileName As String
    Dim strNewFolder As String, strNewFileName As String
    Dim wb As Workbook
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .AllowMultiSelect = False
        If .Show = 0 Then
            Exit Sub
        End If
        strFolder = .SelectedItems(1)
    End With
    
    strNewFolder = strFolder & "_" & Format(Now, "dd.mm.yyyy hh.mm.ss")
    MkDir strNewFolder
    
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    strFileName = Dir(strFolder & "\*.xlsm")
    Do While strFileName <> ""
        Set wb = Workbooks.Open(strFolder & "\" & strFileName)
        strNewFileName = Left(strFileName, InStrRev(strFileName, ".") - 1)
        strNewFileName = strNewFileName & ".xlsx"
        wb.SaveAs strNewFolder & "\" & strNewFileName, xlOpenXMLWorkbook
        wb.Close
        strFileName = Dir
    Loop
    
    Application.EnableEvents = True
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    MsgBox "Готово!", vbInformation
    
End Sub
[/vba]

Автор - Karataev
Дата добавления - 15.03.2016 в 14:57
Sancho Дата: Вторник, 15.03.2016, 14:59 | Сообщение № 4
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 3 ±
Замечаний: 0% ±

2007, 2010, 2013
для перебора файлов посмотрите готовое решение


Спасибо. предложенное решение для перебора файлов хорош, но слишком сложный для моего понимания как срастить ваш код с тем решением. Желание конечно есть разобраться, но без поддержки пока сложно, а методом "научного тыка" не всегда получается желаемый результат.
 
Ответить
Сообщение
для перебора файлов посмотрите готовое решение


Спасибо. предложенное решение для перебора файлов хорош, но слишком сложный для моего понимания как срастить ваш код с тем решением. Желание конечно есть разобраться, но без поддержки пока сложно, а методом "научного тыка" не всегда получается желаемый результат.

Автор - Sancho
Дата добавления - 15.03.2016 в 14:59
Sancho Дата: Вторник, 15.03.2016, 15:06 | Сообщение № 5
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 3 ±
Замечаний: 0% ±

2007, 2010, 2013
Karataev, Спасибо, работает.
 
Ответить
СообщениеKarataev, Спасибо, работает.

Автор - Sancho
Дата добавления - 15.03.2016 в 15:06
StoTisteg Дата: Вторник, 15.03.2016, 21:54 | Сообщение № 6
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
[vba]
Код
    Do While strFileName <> ""
        Set wb = Workbooks.Open(strFolder & "\" & strFileName)
        strNewFileName = Left(strFileName, InStrRev(strFileName, ".") - 1)
        strNewFileName = strNewFileName & ".xlsx"
        wb.SaveAs strNewFolder & "\" & strNewFileName, xlOpenXMLWorkbook
        wb.Close
        strFileName = Dir
    Loop
[/vba]

Зачем такие сложности? Открывать — это очень долго.
[vba]
Код
    Do While strFileName <> ""
        FileCopy Source:=strFolder & "\" & strFileName, Destination:=strFolder & "\" & Left(strFileName, Len(strFileName)-1) & "x"
        Kill strFolder & "\" & strFileName
        strFileName = Dir
    Loop
[/vba]

И короче, и быстрее. Я что-то упустил?


Проверь всё. ThisWorkbook.Save. On Error Resume Next.

Сообщение отредактировал StoTisteg - Вторник, 15.03.2016, 21:59
 
Ответить
Сообщение
[vba]
Код
    Do While strFileName <> ""
        Set wb = Workbooks.Open(strFolder & "\" & strFileName)
        strNewFileName = Left(strFileName, InStrRev(strFileName, ".") - 1)
        strNewFileName = strNewFileName & ".xlsx"
        wb.SaveAs strNewFolder & "\" & strNewFileName, xlOpenXMLWorkbook
        wb.Close
        strFileName = Dir
    Loop
[/vba]

Зачем такие сложности? Открывать — это очень долго.
[vba]
Код
    Do While strFileName <> ""
        FileCopy Source:=strFolder & "\" & strFileName, Destination:=strFolder & "\" & Left(strFileName, Len(strFileName)-1) & "x"
        Kill strFolder & "\" & strFileName
        strFileName = Dir
    Loop
[/vba]

И короче, и быстрее. Я что-то упустил?

Автор - StoTisteg
Дата добавления - 15.03.2016 в 21:54
Karataev Дата: Вторник, 15.03.2016, 22:00 | Сообщение № 7
Группа: Проверенные
Ранг: Ветеран
Сообщений: 837
Репутация: 312 ±
Замечаний: 0% ±

Excel
StoTisteg, вручную (без макросов) измените расширение xlsm на xlsx, а затем откройте файл xlsx. Появится сообщение, что какие-то проблемы.
Таким образом, Ваш способ не подходит, т.к. это более сложный процесс.


 
Ответить
СообщениеStoTisteg, вручную (без макросов) измените расширение xlsm на xlsx, а затем откройте файл xlsx. Появится сообщение, что какие-то проблемы.
Таким образом, Ваш способ не подходит, т.к. это более сложный процесс.

Автор - Karataev
Дата добавления - 15.03.2016 в 22:00
StoTisteg Дата: Вторник, 15.03.2016, 22:28 | Сообщение № 8
Группа: Авторы
Ранг: Ветеран
Сообщений: 541
Репутация: 45 ±
Замечаний: 0% ±

Excel 2010
Мда. Действительно, Вы правы. При ручном прогоне возвращает Permission denied. Обидно, идея была хорошая ^_^


Проверь всё. ThisWorkbook.Save. On Error Resume Next.
 
Ответить
СообщениеМда. Действительно, Вы правы. При ручном прогоне возвращает Permission denied. Обидно, идея была хорошая ^_^

Автор - StoTisteg
Дата добавления - 15.03.2016 в 22:28
Sancho Дата: Четверг, 17.03.2016, 23:20 | Сообщение № 9
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 3 ±
Замечаний: 0% ±

2007, 2010, 2013
Еще подскажите пожалуйста в некоторых файлах откуда то взялись связи. что нужно добавить в макрос Karataevа что бы код сам отменял обновление связей.

ЗЫ: И заметил какую то странную закономерность. на машине с win7-64бит и офисом 2010 и 2013 обрабатывается 2-3 файла в минуту, и как правило исполнение макроса останавливается неожиданно на любом из файлов, без какой либо ошибки, а на машине с winXP-32 бит и офисом 2007 5 файлов минуту и гонит всё без остановки. И на последней железяке отсутствует запрос обновления связей. прогнал на ней уже 6 папок по 500 файлов до конца, а на машинах с win7 всегда всплывает какой то из вышеперечисленных косяков - 3 машины и ни одной обработанной папки по 500 файлов. Причем последняя железка куда более скудная в начинке, чем первые. почему так?
 
Ответить
СообщениеЕще подскажите пожалуйста в некоторых файлах откуда то взялись связи. что нужно добавить в макрос Karataevа что бы код сам отменял обновление связей.

ЗЫ: И заметил какую то странную закономерность. на машине с win7-64бит и офисом 2010 и 2013 обрабатывается 2-3 файла в минуту, и как правило исполнение макроса останавливается неожиданно на любом из файлов, без какой либо ошибки, а на машине с winXP-32 бит и офисом 2007 5 файлов минуту и гонит всё без остановки. И на последней железяке отсутствует запрос обновления связей. прогнал на ней уже 6 папок по 500 файлов до конца, а на машинах с win7 всегда всплывает какой то из вышеперечисленных косяков - 3 машины и ни одной обработанной папки по 500 файлов. Причем последняя железка куда более скудная в начинке, чем первые. почему так?

Автор - Sancho
Дата добавления - 17.03.2016 в 23:20
_Boroda_ Дата: Четверг, 17.03.2016, 23:44 | Сообщение № 10
Группа: Модераторы
Ранг: Экселист
Сообщений: 10334
Репутация: 4357 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПро связи
http://www.excelworld.ru/forum/10-15280-1

Автор - _Boroda_
Дата добавления - 17.03.2016 в 23:44
Karataev Дата: Пятница, 18.03.2016, 09:56 | Сообщение № 11
Группа: Проверенные
Ранг: Ветеран
Сообщений: 837
Репутация: 312 ±
Замечаний: 0% ±

Excel
По поводу связи. Измените эту строку:
[vba]
Код
        Set wb = Workbooks.Open(Filename:=strFolder & "\" & strFileName, UpdateLinks:=False)
[/vba]
По поводу версий. В каждой версии есть свои особенности, на 100% версии не совместимы. Excel 2007 - это не Excel 2010, это уже две разные программы.




Сообщение отредактировал Karataev - Пятница, 18.03.2016, 09:59
 
Ответить
СообщениеПо поводу связи. Измените эту строку:
[vba]
Код
        Set wb = Workbooks.Open(Filename:=strFolder & "\" & strFileName, UpdateLinks:=False)
[/vba]
По поводу версий. В каждой версии есть свои особенности, на 100% версии не совместимы. Excel 2007 - это не Excel 2010, это уже две разные программы.

Автор - Karataev
Дата добавления - 18.03.2016 в 09:56
Sancho Дата: Суббота, 19.03.2016, 18:19 | Сообщение № 12
Группа: Проверенные
Ранг: Форумчанин
Сообщений: 129
Репутация: 3 ±
Замечаний: 0% ±

2007, 2010, 2013
Karataev, спасибо, очень выручили
 
Ответить
СообщениеKarataev, спасибо, очень выручили

Автор - Sancho
Дата добавления - 19.03.2016 в 18:19
Мир MS Excel » Вопросы и решения » Вопросы по VBA » Пакетное "Сохранить как" (Макросы/Sub)
Страница 1 из 11
Поиск:

Яндекс цитирования
© 2010-2017 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!