Updating worksheet problem

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("D12"), _
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

Can you use column A to find the next open spot?

But this line clears out existing stuff on the "to" worksheet:

Worksheets(c.Value).Cells.Clear

I commented it out, but I'm not sure if you want to.

I think this came from Debra Dalgleish's site. Her routine throws away the
existing stuff and refreshes it with the data from the main sheet.

if you wanted to keep the 12 lines of headers, you could do:

worksheets(c.value).Rows("13:65536").Clear



Option Explicit
Sub FilterCities()

Dim c As Range
Dim ws As Worksheet
Dim DestCell As Range

'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

With Sheets(c.Value)
'put it in the next open cell in column A
Set DestCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0)
If DestCell.Row < 13 Then
Set DestCell = .Cells(13, "A")
End If
End With

'transfer data to individual City worksheets
Sheets("MAIN").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("CITIES").Range("D12"), _
CopyToRange:=DestCell, _
Unique:=False
Next
MsgBox "Data has been sent"
End Sub

HamishM wrote:
>
> Hi,
>
> I am using the following code to create new worksheets from a
> pre-existing table. On updating, if there are existing spreadsheets i
> 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("D12"), _
> 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 Function
>
> ---
> Message posted from http://www.ExcelForum.com/

--

Dave Peterson

Thanks Dave - that works a treat.


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