Must copy cell formatting in Excel2010 using VBA

Question

I am attempting to write code to parse a single long spreadsheet into multiple sheets. I have the parse code working, and copy and paste works too. But the paste only creates the cells at the default width. I need to copy ALL cell formatting. That is, cell height, width, background color, foreground color, border etc. That part is generating a run-time 1004 error. Below is my code:

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

I am a very experienced VBA coder, but a complete novice to Excel syntax. Can someone please help me get past this? the "xlPasteAll" attribute fails as well, which is what I tried first using a single PastSpecial method.

Any ideas would be greatly appreciated!

Thanks

Answer 1

Look at adding an .autofit on your range after formatting. That should sort out your problem. Be aware that autofit will stretch cells, you will not get "deep" cells from it.

Answer 2

Try this

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

FOLLOWUP

This works physically, But for some reason, it is not actually copying the formatting (cell sizes etc). It's getting fonts and text colors okay, but not cell sizes or merged cells or visible borders.

Is this what you are trying?

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