主页 / 问题 / 880027
Accepted
Sanvirtus
Asked:2020-09-11 19:58:24 +0000 UTC2020-09-11 19:58:24 +0000 UTC

如何在 VBA 中复制具有列大小的工作表？

  • 772

有一个文档，其中有从 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
vba

1 个回答

  1. Best Answer

    将指定工作表复制到新工作簿

    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
    • 1

相关问题