Yes I would want to run it in the same macro.

Thanks,
Lime

"Ron de Bruin" wrote:

Hi Lime

You can also do it in the same macro if you want ?
Do you want to do that ?

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Ron de Bruin" wrote in message ...
After you create the sheets with the first macro you can run this one to copy the format

--
Regards Ron de Bruin
http://www.rondebruin.nl


"Lime" wrote in message ...
Thanks Again Ron.. Do I put this at the beginning or the end of my code below?

"Ron de Bruin" wrote:

Hi Lime

You can copy the format from "Sheet1" to all other sheets like this

Sub Test()
Dim sh As Worksheet

Application.ScreenUpdating = False
For Each sh In ThisWorkbook.Worksheets
If sh.Name < "Sheet" Then
Sheets("Sheet1").Cells.Copy
With sh.Cells(1, 1)
.PasteSpecial xlPasteFormats, , False, False
Application.CutCopyMode = False
End With
End If
Next
Application.ScreenUpdating = True
End Sub


--
Regards Ron de Bruin
http://www.rondebruin.nl


"Lime" wrote in message ...
Hello,
What I am trying to do is, In coloum "L" sheet1 I have a list of multipal
states, I would like to move the changing states to a new worksheet, so all
NJ to new sheet, all NY to new sheet, ETC....naming the sheet that state This
is the code I'm using, It works great, but for one problem the Format is not
coming over from Sheet1. Is there any way to get the format to come over for
Sheet1 as it is coping over to the new sheets?

The Below code was provided by a member Ron de Bruin, and I am Forever
Greatful.

Sub Copy_With_AdvancedFilter_To_Worksheets()
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long

Set ws1 = Sheets("Sheet1") '<<< Change
Set rng = ws1.Range("A1").CurrentRegion '<<< Change

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

With ws1
rng.Columns(12).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
.Range("IU1").Value = .Range("IV1").Value

For Each cell In .Range("IV2:IV" & Lrow)
.Range("IU2").Value = cell.Value
Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=WSNew.Range("A1"), _
Unique:=False
WSNew.Columns.AutoFit
Next
.Columns("IU:IV").Clear
End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub










Was this post helpful to you?

Why should I rate a post?



Expand AllCollapse All

Manage Your Profile |Contact us
© 2005 Microsoft Corporation. All rights reserved. Terms of Use |Trademarks
|Privacy Statement