Sorry I meant to add there is 7 worksheets of addresses each sheet is a
delivery run.

<'Change this to the sheet CODE NAME of the sheet that contains
Addresses.
Set wsAddresses = Sheet3

This may work for 1 sheet but can I reference just the worksheet in use?

Cheers

Mark


On 10/09/08 4:54 PM, in article
,
" wrote:

Hi Major,
this might work...It will require some modifications.
Copy this into a module in the workbook you are using.
I suppose I could have done this more concisely but this is more
reusable and easier to understand.
Regards
Bernie Russell
-----------------------------------------------------------
Option Explicit
Public wsAddresses As Worksheet
Public col As Range

Public Function FirstRow() As Range
'Dim StartCell As Range
'Set StartCell = Intersect(ws.Rows(1), col)
'
'If StartCell < "" Then
' Set FirstRow = StartCell
'Else
' Set FirstRow = StartCell.End(xlDown)
'End If

'OR use this:
Set FirstRow = wsAddresses.Range("A2") 'Substitute address of first
cell containing an address

End Function

Public Function LastRow() As Range
Dim StartCell As Range
Set StartCell = Intersect(wsAddresses.Rows(65536), col)

If StartCell < "" Then
Set LastRow = StartCell
Else
Set LastRow = StartCell.End(xlUp)
End If

End Function

Public Function RangeWithAddresses() As Range
Set RangeWithAddresses = Range(FirstRow, LastRow)
End Function

Public Function CountOfRows() As Integer
CountOfRows = RangeWithAddresses.Rows.Count
End Function

Sub CreatePostieShares()

Dim iPosties As Integer
Dim iCount As Double
Dim rPosties As Range
Dim c As Range
Dim iStart As Integer
Dim iFinish As Integer
Dim iAddressShare As Integer
Dim rAddressShare As Range
Dim wsPostieShare As Worksheet
Dim wsPosties As Worksheet
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual

'Change this to the sheet CODE NAME of the sheet that contains
Addresses.
Set wsAddresses = Sheet3

'Change this to the column number that contains the addresses
Set col = wsAddresses.Columns(1)
'Create a sheet and place the available posties in the first column
starting at cell A2, add as many as
'you require. Change this to the SHEET CODE NAME of the new sheet.
Set wsPosties = Sheet4
With wsPosties
Set rPosties = .Range(.Range("A2"), .Range("A65536").End(xlUp))
End With

iCount = CountOfRows
iAddressShare = CInt(iCount / rPosties.Cells.Count)
iStart = 1
iFinish = iAddressShare

For Each c In rPosties

With wsAddresses

Set rAddressShare
= .Range(.Columns(1).Cells(iStart), .Columns(1).Cells(iFinish)).EntireRow


If SheetExists(c.Value) = False Then
Set wsPostieShare = ThisWorkbook.Worksheets.Add(, wsPosties)
Else
Set wsPostieShare = Worksheets(c.Value)
End If

With wsPostieShare
.UsedRange.Clear
rAddressShare.Copy .Cells(1) 'or whatever cell you want it to
go in
End With

iStart = iFinish + 1
iFinish = iStart + iAddressShare

End With 'wsAddresses

Next c

.ScreenUpdating = True
.Calculation = xlCalculationAutomatic

End With 'Application

End Sub

Public Function SheetExists(WorksheetName As String) As Boolean
On Error Resume Next
Dim wsTemp As Worksheet
Set wsTemp = Worksheets(WorksheetName)

If Err.Number = 0 Then
SheetExists = True
Else
SheetExists = False
End If

End Function