Splitting multiple row cells into new rows

[cspearsall]

Imaging - ready to work.xlsx
	A	B	C	D	E
1	Procedure Name	Modality Type	Procedure Code	CPT
2	BI BREAST CYST ASPIRATION LEFT	Breast Imaging	IMG617	19000 19000 3611900001	PR PUNCTURE ASPIRATION CYST BREAST PR PUNCTURE ASPIRATION CYST BREAST HC PUNC/ASPIR BREAST CYST
3	BI BREAST CYST ASPIRATION RIGHT	Breast Imaging	IMG1952	19000 19000 3611900001	PR PUNCTURE ASPIRATION CYST BREAST PR PUNCTURE ASPIRATION CYST BREAST HC PUNC/ASPIR BREAST CYST
4	BI BREAST DUCTOGRAM LEFT	Breast Imaging	IMG579	77053 77053 4017705301	CHG MAMMARY DUCTOGRAM OR GALACTOGRAM SINGLE CHG MAMMARY DUCTOGRAM OR GALACTOGRAM SINGLE HC MAMMARY DUCTOGRAM, SINGLE - MAMMO BREAST DUCTOGRAM
Epic - fill in (2)

Cells with Conditional Formatting
Cell	Condition		Cell Format	Stop If True
A1:G1,K1,I1	Cell Value	duplicates	text	YES

I need to find a way to make each of these matching rows in columns D & E into a separate row with the same information from columns A,B&C

 

[James006]

Hi again,

For your actual database with over 1'300 records ... took the time to re-write the macro with Arrays ...
As requested ... it will significantly speed up your whole process

Sub ArrayCopySplitRows()
' cspearsall  - Sat 8 Apr. 2023
' https://www.mrexcel.com/board/threads/splitting-multiple-row-cells-into-new-rows
Dim arr() As Variant
Dim Rng As Range
Dim last As Long
Dim i As Long, j As Long, k As Long
Dim cpt, pro

    ' Add Headers
    Sheet1.Range("A1:E1").Copy Sheet2.Range("A1:E1")
    last = Sheet1.Cells(Rows.count, 1).End(xlUp).row
    'Set range to populate array
    Set Rng = Sheet1.Range("A2:E" & last)
   
    'Resize array to match Final Range Size
    ReDim arr((Rng.Rows.count) * 3, Rng.Columns.count - 1)
   
    'Loop through each row and populate it 3 times to the Array '''
    ' Nb of Times - followed by Columns - followed by Rows
    For k = 0 To 2
        For j = 0 To Rng.Columns.count - 1
            For i = 0 To Rng.Rows.count - 1
                ' Watch the two Dimensions - k +( i * 3)
                arr(k + (i * 3), j) = Sheet1.Cells(i + 2, j + 1)
            Next i
        Next j
    Next k
    Sheet2.Range("A2:E" & (2 + ((Rng.Rows.count) * 3) - 1)).Value = arr
    ' Split Columns D & E - Using separator chr(10) '''
    For i = 2 To Sheet2.Cells(Rows.count, 4).End(xlUp).row Step 3
        cpt = Split(Sheet2.Range("D" & i), Chr(10))
        For j = LBound(cpt) To UBound(cpt)
            Sheet2.Cells(i + j, 4) = cpt(j)
        Next j
        pro = Split(Sheet2.Range("E" & i), Chr(10))
        For j = LBound(pro) To UBound(pro)
            Sheet2.Cells(i + j, 5) = pro(j)
        Next j
    Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Hope this will help

 

[cspearsall]

Is this what you are expecting for results.

Procedure Name	Modality Type	Procedure Code	CPT	Column1
BI BREAST CYST ASPIRATION LEFT	Breast Imaging	IMG617	19000	PR PUNCTURE ASPIRATION CYST BREAST
BI BREAST CYST ASPIRATION LEFT	Breast Imaging	IMG617	19000	HC PUNC/ASPIR BREAST CYST
BI BREAST CYST ASPIRATION LEFT	Breast Imaging	IMG617	3611900001	PR PUNCTURE ASPIRATION CYST BREAST
BI BREAST CYST ASPIRATION LEFT	Breast Imaging	IMG617	3611900001	HC PUNC/ASPIR BREAST CYST
BI BREAST CYST ASPIRATION RIGHT	Breast Imaging	IMG1952	19000	PR PUNCTURE ASPIRATION CYST BREAST
BI BREAST CYST ASPIRATION RIGHT	Breast Imaging	IMG1952	19000	HC PUNC/ASPIR BREAST CYST
BI BREAST CYST ASPIRATION RIGHT	Breast Imaging	IMG1952	3611900001	PR PUNCTURE ASPIRATION CYST BREAST
BI BREAST CYST ASPIRATION RIGHT	Breast Imaging	IMG1952	3611900001	HC PUNC/ASPIR BREAST CYST
BI BREAST DUCTOGRAM LEFT	Breast Imaging	IMG579	77053	CHG MAMMARY DUCTOGRAM OR GALACTOGRAM SINGLE
BI BREAST DUCTOGRAM LEFT	Breast Imaging	IMG579	77053	HC MAMMARY DUCTOGRAM, SINGLE - MAMMO BREAST DUCTOGRAM
BI BREAST DUCTOGRAM LEFT	Breast Imaging	IMG579	4017705301	CHG MAMMARY DUCTOGRAM OR GALACTOGRAM SINGLE
BI BREAST DUCTOGRAM LEFT	Breast Imaging	IMG579	4017705301	HC MAMMARY DUCTOGRAM, SINGLE - MAMMO BREAST DUCTOGRAM

Yes

 

[cspearsall]

Thank you guys...this worked for me.

 

[alansidman]

Here is the Power Query Solution associated with my previous post

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

 

[James006]

Thank you guys...this worked for me.

Hi,

Just out of curiosity, have you tested the macro posted in message # 21 ...?
What was the outcome ... ?