Updating worksheet problem

[HamishM]

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

 

[Dave Peterson]

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]

Thanks Dave - that works a treat.