Separate Comma values in the cell and replacing in a new row by copying the original content

[mayaa_mmm]

I want to split the content in a column (Vendor 1, Vendor 2, Vendor 3) into different rows.

Name	Type	Name	Vendor 1	Vendor 2	Vendor 3	Manager	Available
Apple	1	Kashmir	Padma whole sale	Fruit Junction; Juice corner	Hypercity; Star bazzar	Anthony	multiple
Orange	2	Australia	Padma whole sale;Fruit Junction	Juice corner		Gopi	Single
Grapes	3	Australia		Padma whole sale;Fruit Junction	Hypercity; Star bazzar	Preethi	Multiple

<colgroup><col><col><col><col><col><col><col span="2"></colgroup><tbody>
</tbody>

Final outcome should be like below for every items.

Name	Type	Name	Vendor 1	Vendor 2	Vendor 3	Manager	Available
Apple	1	Kashmir	Padma whole sale			Anthony	multiple
Apple	1	Kashmir		Fruit Junction		Anthony	multiple
Apple	1	Kashmir		Juice corner		Anthony	multiple
Apple	1	Kashmir			Hypercity	Anthony	multiple
Apple	1	Kashmir			Star bazzar	Anthony	multiple

<colgroup><col><col><col><col><col><col><col span="2"></colgroup><tbody>
</tbody>

It will be helpful for us. It will save the tons of Time

 

[bertie]

Using the sample data provided I have assumed:
Data is on Sheet1
Data starts in cell A1.
The code loops through column A until it reaches an empty cell.

Place the code in a standard module, i.e., Insert=>Module
The code loops through the data and generates new output in the columns to the right of the existing data.
Use the sample data provided to test the code.

Option Explicit


Sub ParseData()
   Dim rngRow As Range        'column A entries to loop through
   Dim rowSource As Long      'source row
   Dim rowTarget As Long      'output row
   Dim colTarget As Long      'output column
   Dim arrVendor As Variant
   Dim col As Long            'column loop index
   Dim i As Long              'array loop index
   
   'initialize variables
   Set rngRow = Sheets("Sheet1").Range("A2")
   rowTarget = 1
   
   'loop through rows
   Do Until rngRow = ""
      rowSource = rngRow.Row
      
      'loop through columns
      For col = 4 To 6
         
         'does this cell contain a value?
         If Sheets("Sheet1").Cells(rowSource, col).Value <> "" Then
            
            'populate the vendor array, separate by semi colon
            arrVendor = Split(Sheets("Sheet1").Cells(rowSource, col).Value, ";")
            
            'loop through the array
            For i = LBound(arrVendor) To UBound(arrVendor)
               rowTarget = rowTarget + 1
               
               'output
               With Sheets("Sheet1")
                  .Range("J" & rowTarget).Value = .Range("A" & rowSource).Value  'name
                  .Range("K" & rowTarget).Value = .Range("B" & rowSource).Value  'type
                  .Range("L" & rowTarget).Value = .Range("C" & rowSource).Value  'area
                  .Cells(rowTarget, col + 9).Value = Trim(arrVendor(i))          'vendor
                  .Range("P" & rowTarget).Value = .Range("G" & rowSource).Value  'manager
                  .Range("Q" & rowTarget).Value = .Range("C" & rowSource).Value  'available
               End With
            Next i
         End If
         
      Next col


      'get next row
      Set rngRow = rngRow.Offset(1, 0)
   Loop


   'tidy up
   Set rngRow = Nothing
End Sub