View Single Post
  #2   Report Post  
Posted to microsoft.public.excel.programming
jasontferrell jasontferrell is offline
external usenet poster
 
Posts: 56
Default Copying a differing range of rows to a new worksheet

There are some details I don't know, like the existence of blank rows
between invoices, but try this:

Public Function SeparateInvoices()
Dim shtRaw As Worksheet, shtInv As Worksheet
Dim lRow As Long, lCount As Long, lInitialRows As Long
Dim iSheet As Integer
Set shtRaw = Sheets("RawData")
lInitialRows = shtRaw.UsedRange.Rows.Count
iSheet = 1
Do While lCount < lInitialRows
lRow = 1
Do While Not InStr(1, shtRaw.Cells(lRow, 1).Value, "net
payable to", vbTextCompare) < 0
lRow = lRow + 1
Loop
If lRow 1 Then
Set shtInv = Sheets.Add
shtInv.Name = "Sheet" & iSheet
shtRaw.Range(shtRaw.Cells(1, 1).EntireRow, shtRaw.Cells
(lRow, 1).EntireRow).Copy shtInv.Range("A1")
shtRaw.Range(shtRaw.Cells(1, 1).EntireRow, shtRaw.Cells
(lRow, 1).EntireRow).Delete xlUp
End If
iSheet = iSheet + 1
lCount = lCount + lRow
Loop
Set shtInv = Nothing
Set shtRaw = Nothing
End Function