0

Есть документ в котором есть данные от A1 до AF66. Каждый столбец имеет свою собственную ширину. Как мне скопировать этот лист в новую книгу при это сохранить ширину столбцов?

Я копирую так, но ширина столбцов не сохраняется:

Sub Macros()

    Dim NewWorkbook As Workbook
    Set NewWorkbook = Workbooks.Add

    ' Открываем текущую книгу
    Set CurrentWorkbook = ThisWorkbook
    ' Открываем листы в текущей книге
    Set sheetCurrent = ThisWorkbook.Worksheets(3)

    ' Копируем лист
    sheetCurrent.Range("A1:AF66").Copy Destination:=NewWorkbook.Worksheets(1).Range("A1:AF1")
    ' Также пробовал копировать следующим образом, но тоже ширина столбцов не сохраняется
    ' sheetCurrentCMR.Range("A1:AF66").Copy
    ' NewWorkbook.Worksheets(1).Range("A1").PasteSpecial xlValues
    ' NewWorkbook.Worksheets(1).Range("A1").PasteSpecial xlFormats

End Sub
4
  • В названии - копировать лист, в коде - копируете диапазон. И куда? В новую книгу, как в коде? Что нужно? 11 сен 2018 в 12:01
  • @vikttur можно целый лист, но данные в этом листе расположены в указанных ячейках. Можно диапазон. Без разницы, главное что бы ширина правильная была
    – Sanvirtus
    11 сен 2018 в 12:04
  • При копировании ЛИСТА форматирование сохранится.
    – Akina
    11 сен 2018 в 12:10
  • @Akina покажите как скопировать весь лист
    – Sanvirtus
    11 сен 2018 в 12:21

1 ответ 1

1

Копируем указанный лист в новую книгу

Sub CopySheet()
Dim sht As Worksheet
Dim sPath As String, sFName As String
Dim i As Long
    sPath = ThisWorkbook.Path & "\" ' путь сохранения'
    sFName = "новая.xlsx" ' имя новой книги'
    Set sht = Worksheets("Лист1") ' копируемый лист'

    With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With

    With Workbooks.Add
        sht.Copy Before:=.Sheets(1) ' копируем лист'

        With .Sheets(1) ' в листе можно чего-то поменять/задать'
            .Name = "копия" ' имя листа'
            .Rows(1).Font.Bold = True ' первая строка жирным'
        End With

        For i = .Sheets.Count To 2 Step -1: .Sheets(i).Delete: Next i ' удаляем листы'

        .SaveAs Filename:=sPath & sFName, FileFormat:=xlOpenXMLWorkbook ' сохраняем'
        .Close ' закрываем'
    End With

    With Application: .ScreenUpdating = True: .DisplayAlerts = True: End With
End Sub
3
  • @Akina, спасибо за правку ) 11 сен 2018 в 12:26
  • Да не за что... просто я уже сам втыкался в эту проблему дефолтной подсветки.
    – Akina
    11 сен 2018 в 12:28
  • Спасибо огромное) Сейчас задам следующий вопрос)
    – Sanvirtus
    11 сен 2018 в 12:31

Ваш ответ

By clicking “Отправить ответ”, you agree to our terms of service and acknowledge you have read our privacy policy.

Всё ещё ищете ответ? Посмотрите другие вопросы с метками или задайте свой вопрос.