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]

Should Alan be too busy to design your Power Query M code ... can always suggest a tailor-made macro ...

By the way, regarding CPT - Column D - are all cells structured the very same way : 5 characters , 5 characters, 10 characters with char(10) in between ?

 

[cspearsall]

I was thinking of:
For each row in the sheet:
1. counting the carriage returns in row D (Variable x)
2. looping 1 to X
A. using find to get the ending index of the first row (then save as a variable)
B. using the find with the previous variable +1 to find the index of the end of the second row, etc..
C. Right and Left functions to extract the row contents
D. Then copying it to another sheet in column D with the contents of columns A.B&C

But I am a little stuck in the weeds on how to make it happen


Haven't used power query but looking now

@James006 - no the numbers are not uniform in length

@James006 & @alansidman - this is not an uncommon practice for us to do and if there was a macro I could really speed up my process with the next client

 

[James006]

Are you tempted to dive into designing your own macro ...

If the answer is "Yes" ... Turn on your macro recorder and perform all your tasks for a single row : Row 2

You will have a pretty good start with an initial VBA translation ...

which, then... will only need to be streamlined and included in a Loop to handle your 1'300 records !!!

 

[cspearsall]

Yea, I have done some Macro work before and that is usually my method. But I think the hang up is the moving the data to a new sheet. I've started trying to do now....stay tuned. I'm not saying a power query or some help with the macro would be helpful---

 

[James006]

Feel free, once you have it, to post the backbone of your macro ...

By the way, "moving data to another sheet" boils down to a standard Copy Paste ...

 

[James006]

A quick example to Explode Row 2 ...

Sub ExplodeRow2()
' Quick Example for Row 2
Dim cpt, pro
Dim j As Long
    Sheet1.Range("A1:E1").Copy Sheet2.Range("A1:E1")
    Sheet1.Range("A2:C2").Copy Sheet2.Range("A2:A4"
    Sheet1.Range("D2:E2").Copy Sheet2.Range("D2:E2")
    cpt = Split(Sheet2.Range("D2"), Chr(10))
    For j = LBound(cpt) To UBound(cpt)
        Sheet2.Cells(j + 2, 4) = cpt(j)
    Next j
    pro = Split(Sheet2.Range("E2"), Chr(10))
    For j = LBound(pro) To UBound(pro)
        Sheet2.Cells(j + 2, 5) = pro(j)
    Next j
End Sub

Hope this will help

 

[cspearsall]

Sub Macro2()

' Add an output sheet
Set MainSheet1 = ActiveSheet
MainSheet = ActiveSheet.Name
NumROws = Range("A2", Range("A2").End(xlDown)).Rows.Count
Range("A2").Select
Sheets.Add.Name = "OutputSheet"

[B]For rw = 1 To NumROws[/B]
    Worksheets(MainSheet).Activate
    ProcNameValue = ActiveCell.Offset(0, 0).Value
    ModalityValue = ActiveCell.Offset(0, 1).Value
    ProcCodeValue = ActiveCell.Offset(0, 2).Value
    CPTCellValue = ActiveCell.Offset(0, 3).Value
    CPTArray = Split(CPTCellValue, Chr(10))
    LineCount = UBound(CPTArray)
    DescriptCellValue = ActiveCell.Offset(0, 4).Value
    DescriptArray = Split(DescriptCellValue, Chr(10))

Worksheets("OutputSheet").Activate
    For I = 0 To LineCount
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveCell.Offset(0, 0).Value = ProcNameValue
        ActiveCell.Offset(0, 1).Value = ModalityValue
        ActiveCell.Offset(0, 2).Value = ProcCodeValue
        ActiveCell.Offset(0, 3).Value = CPTArray(I)
        ActiveCell.Offset(0, 4).Value = DescriptArray(I)
    Next I

[B]Next[/B]

End Sub

Its not properly notated yet, nut here it my very simple problem and I'm sure I am missing something small:
1. This iterates back to the same row each time. I can add something that will move the active cell down one at the start of each loop put I know there is a better way to iterate through the rows...any help

The array stuff just came to me and works very well

 

[cspearsall]

I have a working code but I would like to tweak it to make it a lot faster. My Macro switches back and forth between sheets to read and write. Is there a way to do this without visually switching? This seems to slow things way down. Also, I think there is a more elegant solution to iterating through rows than the clunky method I used.

Sub ImagingParse()

' Add an output sheet
Set MainSheet1 = ActiveSheet
MainSheet = ActiveSheet.Name
NumROws = Range("A2", Range("A2").End(xlDown)).Rows.Count
Range("A1").Select
Sheets.Add.Name = "OutputSheet"

For rw = 1 To NumROws - 1200
    Worksheets(MainSheet).Activate
    ActiveCell.Offset(1).Select
    ProcNameValue = ActiveCell.Offset(0, 0).Value
    ModalityValue = ActiveCell.Offset(0, 1).Value
    ProcCodeValue = ActiveCell.Offset(0, 2).Value
    CPTCellValue = ActiveCell.Offset(0, 3).Value
    CPTArray = Split(CPTCellValue, Chr(10))
    LineCount = UBound(CPTArray)
    DescriptCellValue = ActiveCell.Offset(0, 4).Value
    DescriptArray = Split(DescriptCellValue, Chr(10))
    ' Msg = CPTArray(0) & DescriptArray(0)

Worksheets("OutputSheet").Activate
    For I = 0 To LineCount
        Range("A" & Rows.Count).End(xlUp).Offset(1).Select
        ActiveCell.Offset(0, 0).Value = ProcNameValue
        ActiveCell.Offset(0, 1).Value = ModalityValue
        ActiveCell.Offset(0, 2).Value = ProcCodeValue
        ActiveCell.Offset(0, 3).Value = CPTArray(I)
        ActiveCell.Offset(0, 4).Value = DescriptArray(I)
    Next I

Next

End Sub

 

[alansidman]

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

 

[James006]

Hi again,

Below is a macro to be tested ... should Explode All Rows as expected

Sub ExplodeAllRows()
Dim cpt, pro
Dim j As Long, i As Long, x As Long
Dim lastr1 As Long, last2 As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    lastr1 = Sheet1.Cells(Rows.count, 1).End(xlUp).row
    Sheet1.Range("A1:E1").Copy Sheet2.Range("A1:E1")
    For i = 2 To lastr1
        last2 = Sheet2.Cells(Rows.count, 1).End(xlUp).row + 1
        Sheet1.Range("A" & i & ":C" & i).Copy Sheet2.Range("A" & last2 & ":A" & last2 + 2)
        Sheet1.Range("D" & i & ":E" & i).Copy Sheet2.Range("D" & last2 & ":E" & last2 + 2)
    Next i
    x = Sheet2.Cells(Rows.count, 4).End(xlUp).row
    For i = 2 To x 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