How do I added column widths to this code?

[Tarqs]

Can anyone help?

I found this code on another thread ("Copy to new worksheets") but i need to to retain the column widths when the new tab is created. Any help would be much appreciated.

Sub Create_Report()
Dim LastRow As Long, LastCol As Integer, i As Long, iStart As Long, iEnd As Long
Dim ws As Worksheet, r As Range, iCol As Integer, t As Date, Prefix As String
Dim sh As Worksheet, Master As String, Folder As String, Fname As String
On Error Resume Next
Set r = Application.InputBox("Click in the column to extract by", Type:=8)
On Error GoTo 0
If r Is Nothing Then Exit Sub
iCol = r.Column
t = Now
Application.ScreenUpdating = False
With ActiveSheet
    Master = .Name
    LastRow = .Cells(Rows.Count, "A").End(xlUp).Row
    LastCol = .Cells(1, Columns.Count).End(xlToLeft).Column
    .Range(.Cells(10, 1), .Cells(LastRow, LastCol)).Sort Key1:=.Cells(10, iCol), Order1:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
    LastCol = 39
    iStart = 10
    For i = 10 To LastRow
        If .Cells(i, iCol).Value <> .Cells(i + 1, iCol).Value Then
            iEnd = i
            Sheets.Add after:=Sheets(Sheets.Count)
            Set ws = ActiveSheet
            On Error Resume Next
            ws.Name = .Cells(iStart, iCol).Value
            On Error GoTo 0
            .Range(.Cells(9, 1), .Cells(9, LastCol)).Copy Destination:=ws.Cells(1, 1)
            .Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")
            iStart = iEnd + 1
        End If
    Next i
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Thanks in advance

Tarqs

 

[pboltonchina]

Untested so try on a copy of your data. Try changing this

.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")

to this

.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Select
Selection Copy
ws.Range("A2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False

 

[Tarqs]

Re: How do I add column widths to this code?

HI pboltonchina,

Thanks for the response. I get: -

Compile error: Invalid use of property ?

I also can't get either of these options to work if it helps.

.Range(.Cells(9, 1), .Cells(9, LastCol)).Copy Destination:=ws.Cells(1, 1)
[B][COLOR=red]ws.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths[/COLOR][/B]
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")

Above returns "PasteSpecial method of range class failed"

and

.Range(.Cells(9, 1), .Cells(9, LastCol)).Copy Destination:=ws.Cells(1, 1)
[COLOR=red][B].Range(.Cells(9, 1), .Cells(9, LastCol)).Copyws.Cells(1, 1).PasteSpecial Paste:=xlPasteColumnWidths[/B][/COLOR]
.Range(.Cells(iStart, 1), .Cells(iEnd, LastCol)).Copy Destination:=ws.Range("A2")

returns "runtime error 438 Object doesn't support this property or method"

i'm using 2007

Any further assistance or direction is greatfully received

Tarqs