Необходимо скопировать форматирование ячейки в Excel2010, используя VBA

Question

Я пытаюсь написать код для разбора одной длинной таблицы на несколько листов.У меня работает код разбора, и копирование и вставка тоже работает.Но вставка создает только ячейки с шириной по умолчанию.Мне нужно скопировать ВСЕ форматирование ячейки.То есть высота ячейки, ширина, цвет фона, цвет переднего плана, границы и т. Д. Эта часть генерирует ошибку времени выполнения 1004.Ниже приведен мой код:

Sub SplitData()

mycount = 0
myrow = 0

Do
   mycount = mycount + 1
   oldrow = myrow + 1
   Sheets("Master").Select

   Do
      myrow = myrow + 1
   Loop Until Left(Sheets("Master").Range("A" & myrow), 4) = "Run:"

   Sheets.Add
   ActiveSheet.Name = "Data" & mycount
   Sheets("Master").Select
   Rows(oldrow & ":" & myrow).Select
   Selection.Copy
   Sheets("Data" & mycount).Select
   Range("A1").Select
   ActiveSheet.Paste 
   ActiveSheet.PasteSpecial xlPasteFormats ' (THE ERROR OCCURS HERE)
Loop Until Left(Sheets("Master").Range("A" & myrow + 1), 3) = "xxx"

End Sub

Я очень опытный программист VBA, но полный новичок в синтаксисе Excel.Может кто-нибудь помочь мне пройти это?атрибут xlPasteAll также не работает, что я и попробовал вначале, используя один метод PastSpecial.

Любые идеи будут высоко оценены!

Answer 1

Посмотрите, как добавить .autofit к вашему диапазону после форматирования.Это должно решить вашу проблему.Имейте в виду, что автофит растянет клетки, вы не получите «глубокие» клетки от него.

Answer 2

Попробуйте это

Selection.Copy
Sheets("Data" & mycount).Select
With Range("A1")
    .PasteSpecial xlValues
    .PasteSpecial xlPasteFormats
End With

Followup

Это работает физически, но по какой-то причине фактически не копирует форматирование (размеры ячеек и т. Д.). Он получает шрифты и цвета текста, но не размеры ячеек, не объединенные ячейки или видимые границы.

Это то, что вы пытаетесь?

Sub SplitData()
    Dim ws As Worksheet

    mycount = 0
    myrow = 0

    Do
       mycount = mycount + 1
       oldrow = myrow + 1
       Sheets("Master").Select

       Do
          myrow = myrow + 1
       Loop Until Left(Sheets("Master").Range("A" & myrow), 4) = "Run:"

       Set ws = Sheets.Add
       ws.Name = "Data" & mycount
       Sheets("Master").Rows(oldrow & ":" & myrow).Copy ws.Rows(1)
    Loop Until Left(Sheets("Master").Range("A" & myrow + 1), 3) = "xxx"
End Sub