How Do I Retain Table Formatting (Cell Width) When Copying Sheet Information?

It looks like your range is in columns A to G and it looks like you copy the information to the last worksheet in the workbook.

Put the following code at the end of the loop before Next i

Sheets("Ground Level").Range("A2:G2").Copy
    Sheets(sname).PasteSpecial xlPasteFormats

Originally Posted by dflak

It looks like your range is in columns A to G and it looks like you copy the information to the last worksheet in the workbook.

Put the following code at the end of the loop before Next i

Sheets("Ground Level").Range("A2:G2").Copy
    Sheets(sname).PasteSpecial xlPasteFormats

Hi,

Thank you for the response, however when adding them two lines of code in i get a "Run-time error'1004'" Error. It's worth noting that the Range has already been defined in the line

.Rows("1:1").Copy Worksheets(sname).Range("A1")

So i removed the top line of your code, and added just

Sheets(sname).PasteSpecial xlPasteFormats

However, with this i get a "PasteSpecial method of Worksheet class failed" error (also Run-time 1004).

Any ideas?

I have provided a dropbox link to download the excel file. The Module in VB to look at it is Module 1 through to 13. Each module does the same action on each sheet, and compiles it into 2 x Yes/No Sheets. The Call macro allows for a button on the Helvar Snags sheet to auto compile, auto save to pdf etc..


Link: https://www.dropbox.com/s/cbtpv9sxv1...heet.xlsm?dl=0
(this link expires in 7 days)

It's quite inefficient to repeat the same code for every sheet. Just use one routine that takes a sheet as an argument:

Sub CopyToYesNo(wsFrom As Worksheet)

    Dim lrow                        As Long
    Dim i                           As Long
    Dim sname                       As String

    Application.ScreenUpdating = False

    With wsFrom
        lrow = .Range("G" & .Rows.Count).End(xlUp).Row
        For i = 2 To lrow
            sname = .Range("G" & i).Value
            If Not Evaluate("ISREF('" & sname & "'!A1)") Then
                Worksheets.Add(after:=Worksheets(Worksheets.Count)).Name = sname
                .Rows("1:1").Copy
                With Worksheets(sname).Range("A1")
                    .PasteSpecial xlPasteAll
                    .PasteSpecial xlPasteColumnWidths
                End With
            End If
            .Rows(i & ":" & i).Copy
            With Worksheets(sname).Range("A" & .Rows.Count).End(xlUp).Offset(1, 0)
                .PasteSpecial xlPasteAll
                .PasteSpecial xlPasteColumnWidths
            End With

        Next i
    End With

    Application.ScreenUpdating = True

End Sub

Then all you need for each sheet is:

Sub Ground_Floor()
    Call CopyToYesNo(Worksheets("Ground Level"))
End Sub

changing the sheet name as appropriate.

See attached.