G'day Gents,

I have about 8 spreadsheets with anything from 1109 to 1911 rows in each
(addresses)
I also have some VBA code that will divide the number of rows equally &
colour each block of the addresses, making it a bit easier to find the first
& last address.

Is it possible to copy the first & last address of each block into a new
worksheet automatically.

Any help would be GREATLY appreciated.

(Background) This is for posties, so when we work short-staffed & have to
divide a delivery round(s) amongst the rest of the staff we can quickly &
accurately set up the divide. At the moment it still takes the better part
of 1/2 an hour to set up just 1 divide.

Should be fairly easy. Show us your layout and before/after examples.

--
Don Guillett
Microsoft MVP Excel
SalesAid Software

"Major" wrote in message
...
G'day Gents,

I have about 8 spreadsheets with anything from 1109 to 1911 rows in each
(addresses)
I also have some VBA code that will divide the number of rows equally &
colour each block of the addresses, making it a bit easier to find the
first
& last address.

Is it possible to copy the first & last address of each block into a new
worksheet automatically.

Any help would be GREATLY appreciated.

(Background) This is for posties, so when we work short-staffed & have to
divide a delivery round(s) amongst the rest of the staff we can quickly &
accurately set up the divide. At the moment it still takes the better part
of 1/2 an hour to set up just 1 divide.

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

Oops!
Insert this: wsPostieShare.Name = c.Value
Below this: Set wsPostieShare = ThisWorkbook.Worksheets.Add(,
wsPosties)

G'day Bernie,

Sorry I haven't replied sooner but I was sent up north without a internet
connection :(((( & only got back today.

Anyway, this is what I have to divide the runs in the module at the moment.

Public Const xlCIBlack As Long = 1
Public Const xlCIWhite As Long = 2
Public Const xlCIRed As Long = 3
Public Const xlCIBrightGreen As Long = 4
Public Const xlCIBlue As Long = 5
Public Const xlCIYellow As Long = 6
Public Const xlCIPink As Long = 7
Public Const xlCITurquoise As Long = 8
Public Const xlCIDarkRed As Long = 9
Public Const xlCIGreen As Long = 10
Public Const xlCIDarkBlue As Long = 11
Public Const xlCIDarkYellow As Long = 12
Public Const xlCIViolet As Long = 13
Public Const xlCITeal As Long = 14
Public Const xlCIGray25 As Long = 15
Public Const xlCIGray50 As Long = 16
Public Const xlCIPeriwinkle As Long = 17
Public Const xlCIPlum As Long = 18
Public Const xlCIIvory As Long = 19
Public Const xlCILightTurquoise As Long = 20
Public Const xlCIDarkPurple As Long = 21
Public Const xlCICoral As Long = 22
Public Const xlCIOceanBlue As Long = 23
Public Const xlCIIceBlue As Long = 24
'Public const xlCIDarkBlue As long = 25
'Public const xlCIPink As long = 26
'Public const xlCIYellow As long = 27
'Public const xlCITurquoise As long = 28
'Public const xlCIViolet As long = 29
'Public const xlCIDarkRed As long = 30
'Public const xlCITeal As long = 31
'Public const xlCIBlue As long = 32
Public Const xlCISkyBlue As Long = 33
Public Const xlCILightGreen As Long = 35
Public Const xlCILightYellow As Long = 36
Public Const xlCIPaleBlue As Long = 37
Public Const xlCIRose As Long = 38
Public Const xlCILavender As Long = 39
Public Const xlCITan As Long = 40
Public Const xlCILightBlue As Long = 41
Public Const xlCIAqua As Long = 42
Public Const xlCILime As Long = 43
Public Const xlCIGold As Long = 44
Public Const xlCILightOrange As Long = 45
Public Const xlCIOrange As Long = 46
Public Const xlCIBlueGray As Long = 47
Public Const xlCIGray40 As Long = 48
Public Const xlCIDarkTeal As Long = 49
Public Const xlCISeaGreen As Long = 50
Public Const xlCIDarkGreen As Long = 51
Public Const xlCIBrown As Long = 53
Public Const xlCIIndigo As Long = 55
Public Const xlCIGray80 As Long = 56
Sub Share()
Dim nPosties As Long
Dim aryColours
Dim iLastRow As Long
Dim cSharedAddresses As Long
Dim cAddresses As Long
Dim cSpread As Long
Dim iColour As Long
Dim iAddresses As Long
Dim i As Long

aryColours = Array(xlCIRed, xlCIGray25, xlCILightGreen, xlCILightBlue, _
xlCIRose, xlCILime, xlCICoral, xlCISkyBlue, _
xlCIOrange, xlCIPlum, xlCIPaleBlue, xlCIGreen, _
xlCIYellow, xlCIPink, xlCITurquoise, xlCIIvory, _
xlCIOceanBlue, xlCIRose, xlCILavender, xlCITan, _
xlCILightBlue, xlCIGold, xlCITeal, xlCILightYellow, _
xlCIBrown, xlCILightYellow, xlCIAqua,
xlCILightOrange, _
xlCIPeriwinkle, xlCIBlueGray, xlCISeaGreen,
xlCIIndigo)
nPosties = Range("J2").Value
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
cSharedAddresses = Int((iLastRow - 2) / nPosties)
cAddresses = cSharedAddresses
cSpread = nPosties - (iLastRow - 2 - cAddresses * nPosties)
iColour = 1
iAddresses = 1
For i = 3 To iLastRow
Cells(i, "A").Resize(, 6).Interior.ColorIndex = aryColours(iColour -
1)
If iAddresses = cAddresses Then
iColour = iColour + 1
If iColour nPosties Then
iColour = nPosties
End If
iAddresses = 1
Else
iAddresses = iAddresses + 1
End If
If cSpread = iColour And cAddresses = cSharedAddresses Then
cAddresses = cAddresses + 1
End If
Next i

End Sub



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

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