[VBA] Create New tabs based on # of items

[sprigelz]

Good day, I am trying to create a button that will do the following;

1. Search a starting point of data until the first blank spot. See below Img. (Data set begins at; Qty - A51, Item # - D51, Description - O51, Selling Price - O51 (Other data does not need to be copied))
2. Copy/paste a tab to the same number of items found (If 4 items are found, then 3 tabs are created (1 tab is already provided)) Sheet # to be copied is Sheet5.
3. Copy/paste each individual item into a separate tab. Item 1 goes in first tab, Item 2 in 2nd tab, item 3 3rd, etc... until all items are placed in a different tab. Qty, Item #, Description, and Selling Price will all need to be copy/pasted into a specific cell in the new tab.

 

[ranman256]

Sub MakeSheets()
Dim colItms As New Collection
Dim sItm As String
Dim i As Integer

   'collect all items
Sheets("sheet1").Activate
Range("B2").Select
While ActiveCell.Value <> ""
    sItm = ActiveCell.Value
    colItms.Add sItm, sItm
    ActiveCell.Offset(1, 0).Select 'next row
Wend

  'make sheets of all items
For i = 1 To colItms.Count
Sheets("sheet5").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = colItms(i)
Next
Set colItms = Nothing
End Sub

 

[sprigelz]

Thank you for the code. It works great to create the new tabs based on the number of items. However, it does not transfer the item data to each separate sheet. Below is what I have currently based off of your code. Is there any way to get each item row to copy/paste to a specific cell in each sheet.

This could even be a separate button/macro by itself if needed.

Example;
Item 1 - Item # copies to Sheet 1 cell A7
Item 2 - Item # copies to Sheet 2 cell A7
etc...

Private Sub PMFU_Submit_Click()
Range("G3").Value = DateSub.Value
Range("T3").Value = Requestor.Value
Range("AL3").Value = InitOrderQty.Value
Unload Me

Dim colItms As New Collection
Dim sItm As String
Dim i As Integer
'collect all items
Sheet1.Select
Range("A51").Select
While ActiveCell.Value <> ""
sItm = ActiveCell.Value
colItms.Add sItm, sItm
ActiveCell.Offset(1, 0).Select 'next row
    Wend
'make sheets of all items
For i = 1 To colItms.Count
Sheets("Product Master").Copy After:=Sheets(Sheets.Count)
ActiveSheet.Name = colItms(i)
Next
    Set colItms = Nothing
'Hide "master" Product Master sheet
Sheet5.Visible = xlSheetHidden
End Sub