Divide rows equally & extract first & last of each block...Possible?
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
|