Split a row into multiple rows based on a comma delimited string

[Danny54]

Good Afternoon

I have the following worksheet (sheet1)
im needing to split any rows that contain a comma delimited value in the desc column into a new line and maintain all other other values. Is there a easy way?
(you can see that the 1st row desc contains the values blue,red,yellow
this row would be split into 3 rows. See second example below. the output would be a new sheet2.

Thanks

type	case	name	desc	mstr	user	date	date1	time
Inactive	a	chev	blue,red,yellow	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15​
Active	a	ford	green	b	Sam	07/23/2022 at 10:00:00 AM (GMT-0500)	07/11/2022 at 11:09:36 AM (GMT-0500)	4:22:52​

type	case	name	desc	mstr	user	date	date1	time
Inactive	a	chev	blue	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15​
Inactive	a	chev	red	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15​
Inactive	a	chev	yellow	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15​
Active	a	ford	green	b	Sam	07/23/2022 at 10:00:00 AM (GMT-0500)	07/11/2022 at 11:09:36 AM (GMT-0500)	4:22:52​

 

[NdNoviceHlp]

Hi Danny54. You can trial this code. Please save a copy of your wb before U test. HTH. Dave

Sub Test()
Dim LastRow As Integer, LastCol As Integer, Cnt As Integer, SplitIt As Variant
Dim Cnt2 As Integer, TempStr As String, Cnt3 As Integer, Counter As Integer, Rng As Range
Counter = 1
With Sheets("Sheet1")
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
For Cnt = 2 To LastRow
If InStr(.Cells(Cnt, "D"), ",") Then
TempStr = .Cells(Cnt, "D") & ","
SplitIt = Split(TempStr, ",")
For Cnt2 = LBound(SplitIt) To UBound(SplitIt) - 1
Counter = Counter + 1
For Cnt3 = 1 To LastCol
If Cnt3 <> 4 Then
Sheets("Sheet2").Cells(Counter, Cnt3) = Sheets("Sheet1").Cells(Cnt, Cnt3)
Else
Sheets("Sheet2").Cells(Counter, Cnt3) = SplitIt(Cnt2)
End If
Next Cnt3
Next Cnt2
Else
Counter = Counter + 1
For Cnt3 = 1 To LastCol
Sheets("Sheet2").Cells(Counter, Cnt3) = Sheets("Sheet1").Cells(Cnt, Cnt3)
Next Cnt3
End If
Next Cnt
'transfer headers
Set Rng = .Range(.Cells(1, 1), .Cells(1, LastCol))
End With
Rng.Copy Destination:=Sheets("Sheet2").Range("A" & 1)
Application.CutCopyMode = False
End Sub

 

[alansidman]

Alternative solution using Power Query/Get and Transform Data

Book8
	A	B	C	D	E	F	G	H	I
1	type	case	name	desc	mstr	user	date	date1	time
2	Inactive	a	chev	blue,red,yellow	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15
3	Active	a	ford	green	b	Sam	07/23/2022 at 10:00:00 AM (GMT-0500)	07/11/2022 at 11:09:36 AM (GMT-0500)	0.182546296
4
5
6	type	case	name	desc	mstr	user	date	date1	time
7	Inactive	a	chev	blue	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15
8	Inactive	a	chev	red	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15
9	Inactive	a	chev	yellow	a	Tom	04/22/2020 at 01:05:00 AM (GMT-0500)	04/21/2020 at 02:28:46 PM (GMT-0500)	2:57:15
10	Active	a	ford	green	b	Sam	07/23/2022 at 10:00:00 AM (GMT-0500)	07/11/2022 at 11:09:36 AM (GMT-0500)	4:22:52 AM
Sheet1

let
    Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
    #"Split Column by Delimiter" = Table.ExpandListColumn(Table.TransformColumns(Source, {{"desc", Splitter.SplitTextByDelimiter(",", QuoteStyle.Csv), let itemType = (type nullable text) meta [Serialized.Text = true] in type {itemType}}}), "desc")
in
    #"Split Column by Delimiter"

 

[Peter_SSs]

Another macro to consider

Sub NewRows()
  Dim desc As Variant
  Dim r As Long, rws As Long
  
  Application.ScreenUpdating = False
  Sheets("Sheet1").Copy After:=Sheets("Sheet1")
  With ActiveSheet
    For r = .Range("D" & Rows.Count).End(xlUp).Row To 2 Step -1
      desc = Split(.Range("D" & r).Value, ",")
      rws = UBound(desc) + 1
      If rws > 1 Then
        .Rows(r).Copy
        .Rows(r + 1).Resize(rws - 1).Insert
        .Range("D" & r).Resize(rws).Value = Application.Transpose(desc)
      End If
    Next r
  End With
  Application.CutCopyMode = False
  Application.ScreenUpdating = True
End Sub

 

[Danny54]

Thanks for all the help

They all worked successfully

 

[Peter_SSs]

You're welcome. Glad we could help. Thanks for the follow-up.