Hi,

I am using the following code to create new worksheets from
pre-existing table. On updating, if there are existing spreadsheets
need a certain section of each spreadsheet to remain unchanged
A1:H12. How do i do this?


thanks,
Hamish



Option Explicit

Sub FilterCities()
Dim c As Range
Dim ws As Worksheet

'rebuild the CityList
Sheets("MAIN").Columns("H:H").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("CITIES").Range("A1"), _
Unique:=True
Sheets("CITIES").Range("A1").CurrentRegion.Sort _
Key1:=Sheets("CITIES").Range("A2"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
'check for individual City worksheets
For Each c In Range("CityList")
If WksExists(c.Value) = False Then
Set ws = Sheets.Add
ws.Name = c.Value
ws.Move After:=Sheets(Sheets.Count)
' Sheets(Range("CityList").Cells(1, 1).Value) _
' .Rows("1:1").Copy Destination:=ws.Rows("1:1")
Else
Worksheets(c.Value).Cells.Clear
End If
'change the criteria in the Criteria range
Sheets("CITIES").Range("D2").Value = c.Value
'transfer data to individual City worksheets
Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D1:D2"), _
CopyToRange:=Sheets(c.Value).Range("A14"), _
Unique:=False
Next
MsgBox "Data has been sent"
End Sub


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

--
Message posted from http://www.ExcelForum.com