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
|