Copy Sheet and paste value with formatting to new sheet VBA

[mhunguyen]

Hi been a consistent user of this forum and never had the chance to ask anything. But hoping someone could help me with this. I have 4 sheets in a workbook and I want to copy and paste values a range with formating to a new workbook. I have completed the following using the record feature and modified it a bit. This works great for the one sheet that I have. But is there an easy way to apply this same code to the remaining 3 sheets?

Sub CopyWithFormatting()
Sheets("Select").Range("M1:W185").Copy
Workbooks.Add
Columns("A:AF").Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With

With ActiveSheet.Range("B1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Columns("C:C").EntireColumn.AutoFit
Columns("A:A").ColumnWidth = 2
Columns("D:L").ColumnWidth = 11.5
End With
'formating
Sheets("Sheet1").Select
Sheets("Sheet1").Name = "Select"
Range("A7").Select
ActiveWindow.FreezePanes = True
ActiveWindow.Zoom = 80

End Sub

Thanks so much for the help.

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub CopyWithFormatting()
   Dim Ws As Worksheet
   Dim Wbk As Workbook
   Dim Shts As Long, i As Long
   
   Shts = Application.SheetsInNewWorkbook
   Application.SheetsInNewWorkbook = 4
   Set Wbk = Workbooks.Add
   Application.SheetsInNewWorkbook = Shts
   
   For Each Ws In Worksheets
      i = i + 1
      Ws.Range("M1:W185").Copy
      With Wbk(i).Columns("A:AF").Interior
         .Pattern = xlSolid
         .PatternColorIndex = xlAutomatic
         .ThemeColor = xlThemeColorDark1
         .TintAndShade = 0
         .PatternTintAndShade = 0
      End With
      
      With Wbk(i).Range("B1")
         .PasteSpecial xlPasteColumnWidths
         .PasteSpecial xlPasteValues
         .PasteSpecial xlPasteFormats
         .Columns("C:C").EntireColumn.AutoFit
         .Columns("A:A").ColumnWidth = 2
         .Columns("D:L").ColumnWidth = 11.5
         .Parent.Name = Ws.Name
      End With
      'formating
      Wbk(i).Select
      Range("A7").Select
      ActiveWindow.FreezePanes = True
      ActiveWindow.Zoom = 80
   Next Ws
End Sub

 

[mhunguyen]

hi Thanks so much for the fast reply.

I ran that code and a runtime error '438', Object Doesn't support this proper or method begining with line "With Wbk(i).Columns("A:AF").Interior".

Also, the range that I liked to copy and paste value from the current workbook to the new workbook is different on every sheet.

Hi & welcome to MrExcel.
How about

Sub CopyWithFormatting()
   Dim Ws As Worksheet
   Dim Wbk As Workbook
   Dim Shts As Long, i As Long
   
   Shts = Application.SheetsInNewWorkbook
   Application.SheetsInNewWorkbook = 4
   Set Wbk = Workbooks.Add
   Application.SheetsInNewWorkbook = Shts
   
   For Each Ws In Worksheets
      i = i + 1
      Ws.Range("M1:W185").Copy
      With Wbk(i).Columns("A:AF").Interior
         .Pattern = xlSolid
         .PatternColorIndex = xlAutomatic
         .ThemeColor = xlThemeColorDark1
         .TintAndShade = 0
         .PatternTintAndShade = 0
      End With
      
      With Wbk(i).Range("B1")
         .PasteSpecial xlPasteColumnWidths
         .PasteSpecial xlPasteValues
         .PasteSpecial xlPasteFormats
         .Columns("C:C").EntireColumn.AutoFit
         .Columns("A:A").ColumnWidth = 2
         .Columns("D:L").ColumnWidth = 11.5
         .Parent.Name = Ws.Name
      End With
      'formating
      Wbk(i).Select
      Range("A7").Select
      ActiveWindow.FreezePanes = True
      ActiveWindow.Zoom = 80
   Next Ws
End Sub

 

[Fluff]

Oops, forgot the sheets, try

Sub CopyWithFormatting()
   Dim Ws As Worksheet
   Dim Wbk As Workbook
   Dim Shts As Long, i As Long
   
   Shts = Application.SheetsInNewWorkbook
   Application.SheetsInNewWorkbook = 4
   Set Wbk = Workbooks.Add
   Application.SheetsInNewWorkbook = Shts
   
   For Each Ws In Worksheets
      i = i + 1
      Ws.Range("M1:W185").Copy
      With Wbk.Sheets(i).Columns("A:AF").Interior
         .Pattern = xlSolid
         .PatternColorIndex = xlAutomatic
         .ThemeColor = xlThemeColorDark1
         .TintAndShade = 0
         .PatternTintAndShade = 0
      End With
      
      With Wbk.Sheets(i).Range("B1")
         .PasteSpecial xlPasteColumnWidths
         .PasteSpecial xlPasteValues
         .PasteSpecial xlPasteFormats
         .Columns("C:C").EntireColumn.AutoFit
         .Columns("A:A").ColumnWidth = 2
         .Columns("D:L").ColumnWidth = 11.5
         .Parent.Name = Ws.Name
      End With
      'formating
      Wbk.Sheets(i).Select
      Range("A7").Select
      ActiveWindow.FreezePanes = True
      ActiveWindow.Zoom = 80
   Next Ws
End Sub

 

[mhunguyen]

There's no more error. the VBA created a new workbook with 4 sheets and formatting. However, Nothing is being copied over from my source workbook.

thanks

 

[Fluff]

Ok, how about

Sub CopyWithFormatting()
   Dim Ws As Worksheet
   Dim Wbk As Workbook
   Dim Shts As Long, i As Long
   
   Shts = Application.SheetsInNewWorkbook
   Application.SheetsInNewWorkbook = 4
   Set Wbk = Workbooks.Add
   Application.SheetsInNewWorkbook = Shts
   Application.ScreenUpdating = False
   For Each Ws In ThisWorkbook.Worksheets
      i = i + 1
      Ws.Range("M1:W185").Copy
      With Wbk.Sheets(i).Columns("A:AF").Interior
         .Pattern = xlSolid
         .PatternColorIndex = xlAutomatic
         .ThemeColor = xlThemeColorDark1
         .TintAndShade = 0
         .PatternTintAndShade = 0
      End With
      
      With Wbk.Sheets(i).Range("B1")
         .PasteSpecial xlPasteColumnWidths
         .PasteSpecial xlPasteValues
         .PasteSpecial xlPasteFormats
         .Columns("C:C").EntireColumn.AutoFit
         .Columns("A:A").ColumnWidth = 2
         .Columns("D:L").ColumnWidth = 11.5
         .Parent.Name = Ws.Name
      End With
      'formating
      Wbk.Sheets(i).Select
      Range("A7").Select
      ActiveWindow.FreezePanes = True
      ActiveWindow.Zoom = 80
   Next Ws
   Application.CutCopyMode = False
End Sub

 

[mhunguyen]

Hi, Thanks for the quick reply. Now the copy and paste is working, but there is a run-time error '9':Subscript out of range at "With Wbk.Sheets(i).Columns("A:AF").Interior"

 

[Fluff]

Do you have more than 4 sheets in your workbook?

 

[mhunguyen]

I do have more than one sheet. There are 10 sheets in the workbook. Sorry, I should of mentioned it. Thanks!

 

[Fluff]

You said 4 sheets, sodo you want to copy all 10 or just some of them?
if you want all sheets, will it always be 10 sheets?