Data Loop - Move Certain Rows Between Two Keywords

I have a workbook with part data. Each worksheet is an individual part with its data on that sheet. I'm trying to move certain rows between two key words to a separate wb/ws for the top key word. Data looks something like this:

Supplier 1
row
row
row
Supplier 4
row
row
Supplier 15
row
row
row

As I said, each sheet could have only one supplier or a dozen. The number of rows between each supplier also vary. I was trying something like this to do what I need to do:

Code:
DistiStr = "Supplier 1, Supplier 2, Supplier 3, etc etc etc"
DistiArr = Split(DistiStr, ",")
intDistiMax = UBound(DistiArr)
Set VendorWB = Workbooks.Add(xlWBATWorksheet)
VendorWB.SaveAs Filename:="Vendors"

[Code] .......

I see where my logic problem is: It's looping through a3 - lastrow, but I'm going one row extra each time, so when it goes to the top of the loop again, I'm one row to far starting off. I originally did this because if there's only 1 supplier on the sheet, there won't be another supplier name below it to give me my range.