Column Widths help ?

[GazMo]

i knew it would be simple .. whereabouts in the code would it go ...

Sub Split_Supplier_Codes()
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim r As Integer
Dim c As Range
Set ws1 = Sheets("Customers")
Set rng = Range("Customer")

'extract the list of Code Numbers
ws1.Columns("A:A").Copy _
Destination:=Range("Z1")
ws1.Columns("Z:Z").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("X1"), Unique:=True
r = Cells(Rows.Count, "X").End(xlUp).Row

'set up Criteria Area
Range("Z1").Value = Range("A1").Value

For Each c In Range("X2:X" & r)
'add the Code Numbers to the criteria area
ws1.Range("Z2").Value = c.Value
'add new sheet (if required)
'and run advanced filter
If WksExists(c.Value) Then
Sheets(c.Value).Cells.Clear
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Customers").Range("Z1:Z2"), _
CopyToRange:=Sheets(c.Value).Range("A1"), _
Unique:=False
Columns.AutoFit
Else
Set WSNew = Sheets.Add
WSNew.Move After:=Worksheets(Worksheets.Count)
WSNew.Name = c.Value
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Customers").Range("Z1:Z2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=True
End If
Next
ws1.Select
ws1.Columns("Y:Z").Delete
End Sub
Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function

 

[Frank Stone]

hi
Try this
Cells.entirecolumn.autofit
Regards
Frank