Copy string of invoices

[Lukn4it]

I have invoices that all start with the word "Bill" (conveniently in columb "A")and end with the word "copyright" (also conveniently always in columb "A")but all are different body information and different lengths in the amount of cells it takes up. All the invoices are text format and listed in one worksheet vertically one following the other. I need to record a macro that will cut each invoice and paste it into a seperate sheet. It would be even better if I could get it to paste into each sheet based on the account number, but I think that is getting to complicated.

Can anyone help?

 

[Ziggy1]

I think this is what you want

this code will find "Bill and "copyright" and use it to figure out the range to copy (cut out) to a new worksheet, then comes back to the original sheet and stops when all data is copied. You could name the sheets a specific value ( like invoice #)but I don't know where you have it in your data.

Public Sub CopyInvoice()


Dim sRow As String ' start row
Dim eRow As String 'end row
Dim nCheck As String ' Stores cell value to check for


Dim X As Long ' row counter
Dim L As Long ' last row of data range
Dim cRange As String ' current range


Range("A65536").End(xlUp).Select
L = ActiveCell.Row

X = 1

Do Until X > L ' stops at end of data range



cRange = "A" & X


Range(cRange).Select ' moves cell to starting range

'Sets Row where BILL is found

Do Until nCheck = "BILL"

cRange = "A" & X

nCheck = Range(cRange)
sRow = Range(cRange).Row 'start row to cut

X = X + 1

Loop


'Sets Row where Copyright is found

Do Until nCheck = "Copyright"

cRange = "A" & X

nCheck = Range(cRange)
eRow = Range(cRange).Row ' end row to cut

X = X + 1

Loop



Rows(sRow & ":" & eRow).Cut ' range determined from above

Sheets.Add ' add a new worksheet
ActiveSheet.Paste

Sheets("Sheet1").Select ' this is the main Sheet


Loop

End Sub