copy and paste formula
 

The code below lets me filter and create a new sheet for seperate items. It
works fine, what I would like to include in the new worksheets is also the
cell formulas. How do I write that in and where?

Option Explicit
Sub FilterCities()
Dim myCell As Range
Dim wks As Worksheet
Dim DataBaseWks As Worksheet
Dim ListRange As Range
Dim dummyRng As Range
Dim myDatabase As Range
Dim TempWks As Worksheet
Dim rsp As Integer
Dim i As Long
Dim iCol As Long

Application.ScreenUpdating = False

'include bottom most header row
Const TopLeftCellOfDataBase As String = "A10"

'what column has your key values
Const KeyColumn As String = "A"

'where's your data
Set DataBaseWks = Worksheets("MAIN")
i = DataBaseWks.Range(TopLeftCellOfDataBase).Row - 1

rsp = MsgBox("Include headings?", vbYesNo, "Headings")

Set TempWks = Worksheets.Add

With DataBaseWks
Set dummyRng = .UsedRange
Set myDatabase = .Range(TopLeftCellOfDataBase, _
..Cells.SpecialCells(xlCellTypeLastCell))

End With

'rebuild the List
With DataBaseWks
Intersect(myDatabase, .Columns(KeyColumn)).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=TempWks.Range("A1"), _
Unique:=True

'Add the heading to the criteria area
TempWks.Range("D1").Value = _
..Cells(.Range(TopLeftCellOfDataBase).Row, KeyColumn).Value

End With

With TempWks
Set ListRange = .Range("a2", .Cells(.Rows.Count, "A").End(xlUp))

End With

With ListRange
..Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlNo, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom

End With

'check for individual City worksheets
For Each myCell In ListRange.Cells
If WksExists(myCell.Value) = False Then
Set wks = Sheets.Add
On Error Resume Next
wks.Name = myCell.Value
If Err.Number < 0 Then
MsgBox "Please rename: " & wks.Name
Err.Clear

End If
On Error GoTo 0
wks.Move After:=Sheets(Sheets.Count)

Else

Set wks = Worksheets(myCell.Value)
wks.Cells.Clear

End If

If rsp = 6 Then
DataBaseWks.Rows("1:" & i).Copy Destination:=wks.Range("A1")

'code to remove grid lines
wks.Activate
ActiveWindow.DisplayGridlines = False
Cells(11, 1).Select
ActiveWindow.FreezePanes = True

'code to do column widths
For iCol = 1 To Columns.Count
wks.Columns(iCol).ColumnWidth = DataBaseWks.Columns(iCol).ColumnWidth
Next iCol
wks.Rows.AutoFit

End If

'change the criteria in the Criteria range
TempWks.Range("D2").Value = "=" & Chr(34) & "=" & myCell.Value & Chr(34)

'transfer data to individual City worksheets
If rsp = 6 Then
myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1").Offset(i, 0), _
Unique:=False

Else

myDatabase.AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=TempWks.Range("D1:D2"), _
CopyToRange:=wks.Range("A1"), _
Unique:=False

End If

Next myCell
Application.DisplayAlerts = False
TempWks.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Data has been sent"
Sheet1.Activate

End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) 0)

End Function

Many thanks
--
ASU