Copying a different ranges of rows to a new worksheet

[ashandy]

I am using Excel 2003. I have a worksheet called "RawData" which has a continuous list of invoices, I need to separate off the first invoice from the rest of the invoices into a new worksheet and call it "sheet1". The number of rows from cell A1 at the top left corner varies and is never constant from invoice to invoice however the last row of the invoice I need to move always includes the text string "NET PAYABLE TO". So I need to copy all rows from "A1" to the row that has the text to a new worksheet called "sheet1", I then need to delete those rows only from the original "RawData" worksheet, leaving the remaining invoices in "RawData" intact. If it is helpful to you, the first row on every invoice has the text string "TAX INVOICE". There are no empty rows between the "NET PAYABLE TO" row at the end of an invoice and the "TAX INVOICE" row at the start of the next invoice, so it is literally a continuous list.

Can this routine then be continued on all the other invoices in "RawData", copying them to new worksheets in the same workbook "sheet2","sheet3" etc until there is no data left in RawData, bearing in mind that there may be 10 invoices or 100 invoices in the "RawData" sheet.

I hope I explained this OK, I am only just dipping my toe in the water in Excel programming and I am discovering that Excel can be amazingly powerful....in the right hands!

Thanks for any assistance offered, I have spent hours looking at different code examples on the net and attempting to make them work for me but to no avail.

Regards Andy
Cairns, Australia

 

[jbeaucaire]

You ID the column that "TAX INVOICE" appears in? Is that at least consistent?

 

[Mike Blackman]

Hi and welcome to the board,

Maybe;

Sub SplitInv()

Dim lSRow As Long, lERow As Long

With Sheets("Raw Data")
    Do Until Application.CountA(.Columns("B")) = 0
        .Activate
        .Range("A1").Select
        lSRow = .Cells.Find("TAX INVOICE").Row
        lERow = .Cells.Find("NET PAYABLE TO").Row
        .Rows(lSRow & ":" & lERow).Cut
        Sheets.Add After:=Sheets("Raw Data")
        Range("A1").Insert
    Loop
End With

End Sub

I have assumed each invoice hold data in Column B for the CountA check

 

[jbeaucaire]

This should do it:

Option Explicit
Sub TransferInvoices()
Dim rng As Range, FindString As String
Dim lastrow As Long, lastsheet As Long, lastcol As Long
FindString = "TAX INVOICE"
lastsheet = Worksheets.Count
lastcol = Sheets("RawData").UsedRange.Columns.Count
Application.ScreenUpdating = False

StartHere:
lastrow = Sheets("RawData").UsedRange.Rows.Count
With Sheets("RawData").Range("A1:Z" & lastrow)
    Set rng = .Find(What:=FindString, _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
    If Not rng Is Nothing Then
        Range("A1", Cells(rng.Row, lastcol)).Copy
        Worksheets.Add After:=Sheets(lastsheet)
        Sheets(lastsheet + 1).Name = "Sheet" & lastsheet
        Sheets(lastsheet + 1).Range("A1").PasteSpecial xlPasteAll
        Sheets(1).Activate
        Range("A1", Cells(rng.Row, lastcol)).EntireRow.Delete
        lastsheet = Worksheets.Count
        GoTo StartHere:
    Else
        MsgBox "All invoices parsed - total " & lastsheet - 1
    End If
End With
Application.ScreenUpdating = True
End Sub

It should be able to find the strings whereever they are in each row.

 

[ashandy]

Hi Mikey

WOW that works great, actually there is no data in column B, but all I did was include a couple of lines at the start of your code to insert a new column A and the routine works great now. The invoices are pulled from a Unix based software system and all the data is in strings in column A, so no data in any of the other columns!! Now all the invoices are in their own sheets, I have created a macro which parses the rows and changes text to columns and then formats the invoices so they are a bit more professional looking!

The only slight problem with your routine is that it throws up a runtime error "91" "Object variable or With block variable not set" the line that is highlighted in the debug window is

lSRow = .Cells.Find("TAX INVOICE").Row

This only occurs after all the sheets have been created and I think the routine is looking for the next "TAX INVOICE" which of course is not there anymore! Is there some sort of error trap I can put in somewhere to stop this?

Other than this the whole thing is perfection ;o)

Thanks for your kind assistance Mikey.

Regards
Andy

 

[ashandy]

Hi jbeaucaire

I tried your code but it doesn't do anything, the messagebox comes up saying that 0 invoices have been parsed and the RawData worksheet remains as is. If you refer to my reply to Mikie B, the data is all in column A, this includes the text strings "TAX INVOICE" in the first row and "NET PAYABLE TO" in the last row of each invoice.

Thanks for your kind assistance jbeaucaire, it is most appreciated.

Kind regards
Andy

 

[jbeaucaire]

I missed that part about it all being in column A, but it still should've worked, it did on my test data.

Give this streamlined version a try, it too works fine on my made up data.

Option Explicit
Sub TransferInvoices()
Dim rng As Range, lastrow As Long, lastsheet As Long
lastsheet = Worksheets.Count
Application.ScreenUpdating = False

StartHere:
lastrow = Sheets("RawData").UsedRange.Rows.Count
With Sheets("RawData").Range("A1:A" & lastrow)
    Set rng = .Find(What:="TAX INVOICE", _
                After:=.Cells(.Cells.Count), _
                LookIn:=xlValues, _
                LookAt:=xlWhole, _
                SearchOrder:=xlByRows, _
                SearchDirection:=xlNext, _
                MatchCase:=False)
    If Not rng Is Nothing Then
        Range("A1", "A" & rng.Row).Copy
        Worksheets.Add After:=Sheets(lastsheet)
        Sheets(lastsheet + 1).Name = "Sheet" & lastsheet
        Sheets(lastsheet + 1).Range("A1").PasteSpecial xlPasteAll
        Sheets(1).Activate
        Range("A1", "A" & rng.Row).EntireRow.Delete
        lastsheet = Worksheets.Count
        GoTo StartHere:
    Else
        MsgBox "All invoices parsed - total " & lastsheet
    End If
End With
Application.ScreenUpdating = True
End Sub

Here's the sample data I used, it parsed to 7 sheets.

Excel Workbook
	A
1	NET PAYABLE TO:
2
3	TAX INVOICE
4	NET PAYABLE TO:
5
6
7
8
9	TAX INVOICE
10	NET PAYABLE TO:
11
12
13	TAX INVOICE
14	NET PAYABLE TO:
15
16
17
18	TAX INVOICE
19	NET PAYABLE TO:
20
21
22
23	TAX INVOICE
24	NET PAYABLE TO:
25
26	TAX INVOICE
RawData

 

[Mike Blackman]

Hi,

I knew I'd forgotten something, note I have also changed the Column for the CountA, If you have a report header that sits in Column A just change the = 0 to = 1;

Sub SplitInv()

Dim lSRow As Long, lERow As Long

On Error GoTo Handler

With Sheets("Raw Data")
    Do Until Application.CountA(.Columns("A")) = 0
        .Activate
        .Range("A1").Select
        lSRow = .Cells.Find("TAX INVOICE").Row
        lERow = .Cells.Find("NET PAYABLE TO").Row
        .Rows(lSRow & ":" & lERow).Cut
        Sheets.Add After:=Sheets("Raw Data")
        Range("A1").Insert
    Loop
End With

Handler:

End Sub

 

[Mike Blackman]

And if you wish to delete the Raw Data sheet then use this;

Sub SplitInv()

Dim lSRow As Long, lERow As Long

Application.DisplayAlerts = False

On Error GoTo Handler

With Sheets("Raw Data")
    Do Until Application.CountA(.Columns("A")) = 0
        .Activate
        .Range("A1").Select
        lSRow = .Cells.Find("TAX INVOICE").Row
        lERow = .Cells.Find("NET PAYABLE TO").Row
        .Rows(lSRow & ":" & lERow).Cut
        Sheets.Add After:=Sheets("Raw Data")
        Range("A1").Insert
    Loop
    .Delete
End With

Handler:

Application.DisplayAlerts = True

End Sub

 

[ashandy]

Brilliant Mikey!!

Thanks very much for all your help.

Cheers!
Andy