View Single Post
  #1   Report Post  
Posted to microsoft.public.excel.programming
Lime Lime is offline
external usenet poster
 
Posts: 56
Default Moving Changing Data to New worksheets

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