Try this adaption of the code. I change the Advanced Filter to filter in place and then copy. 
Sub FilterCities()
' Developed by Contextures Inc.
' www.contextures.com
'last edited March 18, 2004


    Dim wks As Worksheet
    Dim DataBaseWks As Worksheet
    Dim TempWks As Worksheet
    Dim myCell As Range
    Dim ListRange As Range
    Dim dummyRng As Range
    Dim myDatabase As Range
    Dim rsp As Integer
    Dim i As Long

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

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

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

    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 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")
        End If

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

        'transfer data to individual worksheets
        If rsp = 6 Then
            myDatabase.AdvancedFilter _
                    Action:=xlFilterInPlace, _
                    CriteriaRange:=TempWks.Range("D1:D2")
            With wks
                myDatabase.SpecialCells(xlCellTypeVisible).Copy Destination:=.Range("A1").Offset(i, 0)
            End With
        Else
            myDatabase.AdvancedFilter _
                    Action:=xlFilterInPlace, _
                    CriteriaRange:=TempWks.Range("D1:D2")
            With wks
                myDatabase.SpecialCells(xlCellTypeVisible).Copy Destination:=.Range("A1")
            End With

        End If
    Next myCell

    Application.DisplayAlerts = False
    TempWks.Delete
    Application.DisplayAlerts = True

    MsgBox "CS Data Report Individual Sheets have been updated"

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