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

Вход

Регистрация

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

 

= Мир MS Excel/копирование листа из книг и создание новых книг с листом - Мир MS Excel

Регистрация · Логин: · Пароль: · · Забыли пароль?
  • Страница 1 из 1
  • 1
Модератор форума: _Boroda_, Manyasha, SLAVICK, китин  
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование листа из книг и создание новых книг с листом (Макросы/Sub)
копирование листа из книг и создание новых книг с листом
Мурад Дата: Вторник, 14.01.2020, 15:21 | Сообщение № 1
Группа: Проверенные
Ранг: Обитатель
Сообщений: 479
Репутация: 17 ±
Замечаний: 0% ±

Excel 2007
Добрый день!
Прошу проверить макрос, который запускает цикл по книгам: открытие книги (xlsb), копирование листа "Смета", создание новой одноименной книги с одним листом "Смета" (xlsx) и вставка сюда из книги (xlsb) листа "Смета", сохранение книги (xlsx), закрытие книги без сохранение (xlsb). Макрос все копирует, но не сохраняет новый файл.
Суть макроса в том, чтобы изменить расширение файла с (xlsb) на (xlsx), оставив только 1 лист "Смета". Прилагаю код макроса:
[vba]
Код
Option Explicit
Sub SaveFilesAs()
    Dim FilesToOpen, i As Integer
    Dim iBeginRange As Object, wsSh As Object, newWS As Object, wsInNewWB As Object
    Dim sCopyAddress As String
    Dim lCalc As Long, lCol As Long, lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wbAct As Workbook, newWB As Workbook
    
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="MS Excel files (*.xls*), *.xls*", MultiSelect:=True, Title:="Files to Merge")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбран ни один файл!"
        Exit Sub
    End If
    
    'диапазон выборки с книг - c первой ячейки
    Set iBeginRange = Range("A1")
    
    'отключаем обновление экрана, автопересчет формул и отслеживание событий
    'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    End With
    
    'цикл по книгам
    i = 1
    While i <= UBound(FilesToOpen)
        Set wbAct = Workbooks.Open(Filename:=FilesToOpen(i))

        Set newWS = wbAct.Sheets("Смета")
       
        'создаем новую книгу newWB с одним листом newWs
        Set newWB = Workbooks.Add(xlWBATWorksheet)
        newWB.Worksheets.Add().Name = "Смета"
        Set wsInNewWB = newWB.Worksheets("Смета")
        
        'копируем значения с созданного листа
        newWS.Copy
        wsInNewWB.Paste
                
        'сохраним созданную книгу как xlsx
        newWB.SaveAs _
        Filename:=wbAct.Path & "" & Replace(wbAct.Name, ".xlsb", ".xlsx", , , vbTextCompare), FileFormat:=xlWorkbookDefault
        newWB.Close savechanges:=True
         
        'закрываем текущую книгу и не сохраняем изменения
        wbAct.Close savechanges:=False
        i = i + 1
    Wend
    
    With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
    End With
End Sub
[/vba]


Сообщение отредактировал Мурад - Вторник, 14.01.2020, 15:22
 
Ответить
СообщениеДобрый день!
Прошу проверить макрос, который запускает цикл по книгам: открытие книги (xlsb), копирование листа "Смета", создание новой одноименной книги с одним листом "Смета" (xlsx) и вставка сюда из книги (xlsb) листа "Смета", сохранение книги (xlsx), закрытие книги без сохранение (xlsb). Макрос все копирует, но не сохраняет новый файл.
Суть макроса в том, чтобы изменить расширение файла с (xlsb) на (xlsx), оставив только 1 лист "Смета". Прилагаю код макроса:
[vba]
Код
Option Explicit
Sub SaveFilesAs()
    Dim FilesToOpen, i As Integer
    Dim iBeginRange As Object, wsSh As Object, newWS As Object, wsInNewWB As Object
    Dim sCopyAddress As String
    Dim lCalc As Long, lCol As Long, lLastrow As Long, lLastRowMyBook As Long, li As Long, iLastColumn As Integer
    Dim wbAct As Workbook, newWB As Workbook
    
    'вызываем диалог выбора файлов для импорта
    FilesToOpen = Application.GetOpenFilename _
      (FileFilter:="MS Excel files (*.xls*), *.xls*", MultiSelect:=True, Title:="Files to Merge")
    If TypeName(FilesToOpen) = "Boolean" Then
        MsgBox "Не выбран ни один файл!"
        Exit Sub
    End If
    
    'диапазон выборки с книг - c первой ячейки
    Set iBeginRange = Range("A1")
    
    'отключаем обновление экрана, автопересчет формул и отслеживание событий
    'для скорости выполнения кода и для избежания ошибок, если в книгах есть иные коды
    With Application
        lCalc = .Calculation
        .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlManual
    End With
    
    'цикл по книгам
    i = 1
    While i <= UBound(FilesToOpen)
        Set wbAct = Workbooks.Open(Filename:=FilesToOpen(i))

        Set newWS = wbAct.Sheets("Смета")
       
        'создаем новую книгу newWB с одним листом newWs
        Set newWB = Workbooks.Add(xlWBATWorksheet)
        newWB.Worksheets.Add().Name = "Смета"
        Set wsInNewWB = newWB.Worksheets("Смета")
        
        'копируем значения с созданного листа
        newWS.Copy
        wsInNewWB.Paste
                
        'сохраним созданную книгу как xlsx
        newWB.SaveAs _
        Filename:=wbAct.Path & "" & Replace(wbAct.Name, ".xlsb", ".xlsx", , , vbTextCompare), FileFormat:=xlWorkbookDefault
        newWB.Close savechanges:=True
         
        'закрываем текущую книгу и не сохраняем изменения
        wbAct.Close savechanges:=False
        i = i + 1
    Wend
    
    With Application
        .ScreenUpdating = True: .EnableEvents = True: .Calculation = lCalc
    End With
End Sub
[/vba]

Автор - Мурад
Дата добавления - 14.01.2020 в 15:21
Pelena Дата: Вторник, 14.01.2020, 18:38 | Сообщение № 2
Группа: Админы
Ранг: Местный житель
Сообщений: 15018
Репутация: 3283 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Здравствуйте.
При сохранении забыли слэш \
И создать книгу с одним листом Смета можно немного короче, если я правильно уловила суть
[vba]
Код
    While i <= UBound(FilesToOpen)
        Set wbAct = Workbooks.Open(Filename:=FilesToOpen(i))

        Set newWS = wbAct.Sheets("Смета")
    
        'создаем новую книгу newWB с одним листом newWs Смета
        newWS.Copy
        Set newWB = ActiveWorkbook
        
        'сохраним созданную книгу как xlsx
        newWB.SaveAs _
        Filename:=wbAct.Path & "\" & Replace(wbAct.Name, ".xlsb", ".xlsx", , , vbTextCompare), FileFormat:=xlWorkbookDefault
        newWB.Close savechanges:=True
        
        'закрываем текущую книгу и не сохраняем изменения
        wbAct.Close savechanges:=False
        i = i + 1
    Wend
[/vba]
имя файла даже можно короче записать
[vba]
Код
        newWB.SaveAs _
        Filename:=Replace(wbAct.FullName, ".xlsb", ".xlsx", , , vbTextCompare), FileFormat:=xlWorkbookDefault
[/vba]


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеЗдравствуйте.
При сохранении забыли слэш \
И создать книгу с одним листом Смета можно немного короче, если я правильно уловила суть
[vba]
Код
    While i <= UBound(FilesToOpen)
        Set wbAct = Workbooks.Open(Filename:=FilesToOpen(i))

        Set newWS = wbAct.Sheets("Смета")
    
        'создаем новую книгу newWB с одним листом newWs Смета
        newWS.Copy
        Set newWB = ActiveWorkbook
        
        'сохраним созданную книгу как xlsx
        newWB.SaveAs _
        Filename:=wbAct.Path & "\" & Replace(wbAct.Name, ".xlsb", ".xlsx", , , vbTextCompare), FileFormat:=xlWorkbookDefault
        newWB.Close savechanges:=True
        
        'закрываем текущую книгу и не сохраняем изменения
        wbAct.Close savechanges:=False
        i = i + 1
    Wend
[/vba]
имя файла даже можно короче записать
[vba]
Код
        newWB.SaveAs _
        Filename:=Replace(wbAct.FullName, ".xlsb", ".xlsx", , , vbTextCompare), FileFormat:=xlWorkbookDefault
[/vba]

Автор - Pelena
Дата добавления - 14.01.2020 в 18:38
Мурад Дата: Среда, 15.01.2020, 10:14 | Сообщение № 3
Группа: Проверенные
Ранг: Обитатель
Сообщений: 479
Репутация: 17 ±
Замечаний: 0% ±

Excel 2007
Pelena, спасибо большое!
Теперь все создает правильно. Единственное, надо будет поправить в коде, чтобы копировал значения+форматы. Т.к. лист "Смета" ссылается на другие листы в книге. Не пойму только, куда вставить в новом предложенном коде уточнения:
PasteSpecial xlPasteValues
PasteSpecial xlPasteFormats
Сразу после
[vba]
Код
newWS.Copy
[/vba] ?
 
Ответить
СообщениеPelena, спасибо большое!
Теперь все создает правильно. Единственное, надо будет поправить в коде, чтобы копировал значения+форматы. Т.к. лист "Смета" ссылается на другие листы в книге. Не пойму только, куда вставить в новом предложенном коде уточнения:
PasteSpecial xlPasteValues
PasteSpecial xlPasteFormats
Сразу после
[vba]
Код
newWS.Copy
[/vba] ?

Автор - Мурад
Дата добавления - 15.01.2020 в 10:14
Pelena Дата: Среда, 15.01.2020, 10:20 | Сообщение № 4
Группа: Админы
Ранг: Местный житель
Сообщений: 15018
Репутация: 3283 ±
Замечаний: ±

Excel 2010, 2016 & Mac Excel
Если надо вместо формул значения, попробуйте после [vba]
Код
Set newWB = ActiveWorkbook
[/vba] добавить
[vba]
Код
newWB.Sheets("Смета").UsedRange.Value=newWB.Sheets("Смета").UsedRange.Value
[/vba]


"Черт возьми, Холмс! Но как??!!"
ЯД 41001765434816
 
Ответить
СообщениеЕсли надо вместо формул значения, попробуйте после [vba]
Код
Set newWB = ActiveWorkbook
[/vba] добавить
[vba]
Код
newWB.Sheets("Смета").UsedRange.Value=newWB.Sheets("Смета").UsedRange.Value
[/vba]

Автор - Pelena
Дата добавления - 15.01.2020 в 10:20
Мурад Дата: Среда, 15.01.2020, 10:46 | Сообщение № 5
Группа: Проверенные
Ранг: Обитатель
Сообщений: 479
Репутация: 17 ±
Замечаний: 0% ±

Excel 2007
Работает :)
Но только с книгами, где нет защиты листов паролем. Если пароль известен, допустим "123", его нужно где-то применить в коде?
 
Ответить
СообщениеРаботает :)
Но только с книгами, где нет защиты листов паролем. Если пароль известен, допустим "123", его нужно где-то применить в коде?

Автор - Мурад
Дата добавления - 15.01.2020 в 10:46
boa Дата: Среда, 15.01.2020, 11:48 | Сообщение № 6
Группа: Проверенные
Ранг: Обитатель
Сообщений: 459
Репутация: 124 ±
Замечаний: 0% ±

2013, 365
[vba]
Код
Application.ActiveWorkbook.ActiveSheet.Unprotect "123"
[/vba]
ну или в вашем случае
[vba]
Код
newWS.Unprotect "123"
[/vba]


 
Ответить
Сообщение[vba]
Код
Application.ActiveWorkbook.ActiveSheet.Unprotect "123"
[/vba]
ну или в вашем случае
[vba]
Код
newWS.Unprotect "123"
[/vba]

Автор - boa
Дата добавления - 15.01.2020 в 11:48
Мурад Дата: Среда, 15.01.2020, 12:01 | Сообщение № 7
Группа: Проверенные
Ранг: Обитатель
Сообщений: 479
Репутация: 17 ±
Замечаний: 0% ±

Excel 2007
boa, благодарю!
 
Ответить
Сообщениеboa, благодарю!

Автор - Мурад
Дата добавления - 15.01.2020 в 12:01
_Boroda_ Дата: Среда, 15.01.2020, 23:45 | Сообщение № 8
Группа: Модераторы
Ранг: Местный житель
Сообщений: 15747
Репутация: 6143 ±
Замечаний: 0% ±

2003; 2007; 2010; 2013 RUS
Поскольку
лист "Смета" ссылается на другие листы в книге
, то думаю, что лучше будет просто разорвать связи, чем копировать значения-форматы. Быстрее, да и не слетит ничего, как вот в этой теме http://www.excelworld.ru/forum/10-41983-278605-16-1559135122
Код разрыва связей тоже по ссылке, пост #4


Скажи мне, кудесник, любимец ба’гов...
Платная помощь:
Boroda_Excel@mail.ru
Яндекс-деньги: 41001632713405 | Webmoney: R289877159277; Z102172301748; E177867141995
 
Ответить
СообщениеПоскольку
лист "Смета" ссылается на другие листы в книге
, то думаю, что лучше будет просто разорвать связи, чем копировать значения-форматы. Быстрее, да и не слетит ничего, как вот в этой теме http://www.excelworld.ru/forum/10-41983-278605-16-1559135122
Код разрыва связей тоже по ссылке, пост #4

Автор - _Boroda_
Дата добавления - 15.01.2020 в 23:45
Мир MS Excel » Вопросы и решения » Вопросы по VBA » копирование листа из книг и создание новых книг с листом (Макросы/Sub)
  • Страница 1 из 1
  • 1
Поиск:

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