Text to columns vba

[austlee]

Thank you in advance for anyone willing to solve this problem. I'm in need of a solution for an excel file in which each cell within two columns labeled, "Primary Diagnosis" and "Secondary Diagnosis" of a 100 column worksheet contain multiple ICD-9 or ICD-10(Industry Standard Diagnosis Codes) diagnosis codes. For example, ICD-10 code "J18.9" is assigned to the description, "Community acquired pneumonia" and "C50.912" is "Malignant neoplasm of left breast". Also, this daily file can contain any amount of rows/records so please factor this in.


Because each individual cell within the "Primary Diagnosis" field and "Secondary Diagnosis" fields contain many ICD-9 or ICD-10 codes, I am attempting break out the codes from these two columns into their respective column assignment of "First Diagnosis Description", "First Diagnosis Code", "Second Diagnosis Description", "Second Diagnosis Code", "Third Diagnosis Description", "Third Diagnosis Code", "Fourth Diagnosis Description", "Fourth Diagnosis Code" and so on. This expansion will go on until the 30th(60 columns) but not all 60 columns will be used depending on how many ICD-9/ICD-10 codes are housed within the cell.

I am very familiar with the text to columns function, however, it wont work to 100% accuracy because of the way each cell is configured in "Primary Diagnosis" field and "Secondary Diagnosis" columns. If one were to use the "Text to Columns" excel function with the delimiters set at ";" and "(" then the output to subsequent columns would place values in the incorrect columns. An example below, "Non-ST elevation myocardial infarction (NSTEMI), initial care episode (I21.4);" would output to subsequent columns as such, 1st Diagnosis Description -"Non-ST elevation myocardial infarction", 1st Diagnosis Code - "NSTEMI, initial care episode)" and 2nd Diagnosis Description - "I21.4)" instead of 2nd Diagnosis Description - "Non-ST elevation myocardial infarction (NSTEMI), initial care episode",1st Diagnosis Code -"I21.4)". Another example is, "Hypertension; Hypertension (I10);" will incorrectly output to, 1st Diagnosis Description - "Hypertension", 1st Diagnosis Code - "Hypertension", 2nd Diagnosis Description - "I10)" instead of 1st Diagnosis Description - "Hypertension Hypertension" and 1st Diagnosis Code- "I10)". If this seems confusing, try plugging in the below example into excel and use the text to columns function with delimiters being set at ";" and "(" to see an example of the output.
Possible Multi-part VBA Solution: Is there a way to search for anything within parenthesis which contains a decimal point and move it over to its respective Diagnosis Code column(1st Diagnosis Code, 2nd Diagnosis Code, 3rd Diagnosis Code)and then move its associated description to its respective column(1st Diagnosis Description, 2nd Diagnosis Description) .

I will show a before and after example of what I am looking to achieve in the ideal sense-

Below is a small example of the file but without the 100 column layout I was referring to earlier:
Before
[TABLE="class: cms_table_grid, width: 700, align: left"]
<tbody>[TR]
[TD]Medical Record Number[/TD]
[TD]Provider[/TD]
[TD]Patient[/TD]
[TD]Primary Diagnosis[/TD]
[TD]Secondary Diagnosis[/TD]
[TD]Financial Class[/TD]
[TD]Report Date[/TD]
[TD]Billing Provider[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]Doe, John S.[/TD]
[TD]Doe, Jane S.[/TD]
[TD][TABLE="class: cms_table, width: 150"]
<tbody>[TR]
[TD="width: 96"]Non-ST elevation myocardial infarction (NSTEMI), initial care episode (I21.4); Acute on chronic diastolic congestive heart failure, NYHA class 3 (I50.33); Multiple sclerosis (340);[/TD]
[/TR]
</tbody>[/TABLE]

[/TD]
[TD]Acute respiratory failure (J96.00); AF (atrial fibrillation) (I48.91); Hypertension; Hypertension (I10); Pneumonia (J18.9);[/TD]
[TD]Medicare[/TD]
[TD]1/1/15[/TD]
[TD]Doe, John S.[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]Doe, John S[/TD]
[TD]Doe, Jane S.[/TD]
[TD]Hypertension (401.9); Hypertension (I10);[/TD]
[TD]Acute respiratory failure (J96.00); AF (atrial fibrillation) (I48.91); Hypertension; Hypertension (I10); Pneumonia (J18.9);[/TD]
[TD]Oxford[/TD]
[TD]1/1/15[/TD]
[TD]Doe, John S.[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]Doe, John S[/TD]
[TD]Doe, Jane S.[/TD]
[TD]Counseling regarding advanced directives and goals of care (Z71.89);[/TD]
[TD]Acute ischemic stroke (I63.50); Cardiac arrest (I46.9); Cerebral anoxic injury (G93.1); Cerebrovascular accident (CVA) (I63.9); Non-ST elevation myocardial infarction (NSTEMI), initial care episode (I21.4);[/TD]
[TD]Medicaid[/TD]
[TD]1/1/15[/TD]
[TD]Doe, John S.[/TD]
[/TR]
[TR]
[TD]AFTER[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]





[TABLE="class: cms_table_grid, width: 700, align: left"]
<tbody>[TR]
[TD]Medical Record Number[/TD]
[TD]Provider[/TD]
[TD]Patient[/TD]
[TD]1st Diagnosis Description[/TD]
[TD]1st Diagnosis Code[/TD]
[TD]2nd Diagnosis Description[/TD]
[TD]2nd Diagnosis Code[/TD]
[TD]3rd Diagnosis Description[/TD]
[TD]3rd Diagnosis Code[/TD]
[TD]4th Diagnosis Description[/TD]
[TD]4th Diagnosis Code[/TD]
[TD]5th Diagnosis Description[/TD]
[TD]5th Diagnosis Code[/TD]
[TD]6th Diagnosis Description[/TD]
[TD]6th Diagnosis Code[/TD]
[TD]7th Diagnosis Description[/TD]
[TD]7th Diagnosis Code[/TD]
[TD]Financial Class[/TD]
[TD]Report Date[/TD]
[TD]Billing Provider[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]Doe, John S.[/TD]
[TD]Doe, Jane S.[/TD]
[TD][TABLE="class: cms_table, width: 150"]
<tbody>[TR]
[TD="width: 96"]Non-ST elevation myocardial infarction (NSTEMI), initial care episode[/TD]
[/TR]
</tbody>[/TABLE]

[/TD]
[TD]I21.4[/TD]
[TD]Acute on chronic diastolic congestive heart failure, NYHA class 3[/TD]
[TD]I50.33[/TD]
[TD]Multiple sclerosis[/TD]
[TD]340[/TD]
[TD]Acute respiratory failure[/TD]
[TD]J96.00[/TD]
[TD]AF (atrial fibrillation)[/TD]
[TD]I48.91[/TD]
[TD]Hypertension; Hypertension[/TD]
[TD]I10[/TD]
[TD]Pneumonia[/TD]
[TD]J18.9[/TD]
[TD]Medicare[/TD]
[TD]1/1/15[/TD]
[TD]Doe, John S.[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]Doe, John S[/TD]
[TD]Doe, Jane S.[/TD]
[TD]Hypertension[/TD]
[TD]401.9[/TD]
[TD]Hypertension[/TD]
[TD]I10[/TD]
[TD]Acute respiratory failure[/TD]
[TD]J96.00[/TD]
[TD]AF (atrial fibrillation)[/TD]
[TD]I48.91[/TD]
[TD]Hypertension; Hypertension[/TD]
[TD]I10[/TD]
[TD]Pneumonia[/TD]
[TD]J18.9[/TD]
[TD][/TD]
[TD][/TD]
[TD]Oxford[/TD]
[TD]1/1/15[/TD]
[TD]Doe, John S.[/TD]
[/TR]
[TR]
[TD]123456[/TD]
[TD]Doe, John S[/TD]
[TD]Doe, Jane S.[/TD]
[TD]Counseling regarding advanced directives and goals of care (Z71.89);[/TD]
[TD]Z71.89[/TD]
[TD]Acute ischemic stroke[/TD]
[TD]I63.50[/TD]
[TD]Cardiac arrest[/TD]
[TD]I46.9[/TD]
[TD]Cerebral anoxic injury[/TD]
[TD]G93.1[/TD]
[TD]Cerebrovascular accident (CVA)[/TD]
[TD]I63.9[/TD]
[TD]Non-ST elevation myocardial infarction (NSTEMI), initial care episode[/TD]
[TD]I21.4[/TD]
[TD][/TD]
[TD][/TD]
[TD]Me[/TD]
[/TR]
</tbody>[/TABLE]

 

[Akuini]

Hi, austlee
Try this (run both macro):
I assumed:
-The original data has 8 columns
-There's always character ");" in the end of each diagnosis code

Sub a926581a()
Dim i As Long
Dim j As Long
Dim arr1
Dim arr2

Application.ScreenUpdating = False
arr1 = Range("F1:H1")
Cells(1, 64).Resize(1, 3) = arr1
arr2 = Split("1st Diagnosis Description:1st Diagnosis Code:2nd Diagnosis Description" & _
":2nd Diagnosis Code:3rd Diagnosis Description:3rd Diagnosis Code", ":")
Cells(1, 4).Resize(1, 6) = arr2
j = 4

For i = 10 To 63
    Cells(1, i) = j & "th" & " Diagnosis Description"
    i = i + 1
    Cells(1, i) = j & "th" & " Diagnosis Code"
    j = j + 1
Next i

    'change column width
    Columns("A:C").ColumnWidth = 12
    Columns("BL:BN").ColumnWidth = 12
    
    For i = 4 To 63 Step 2
    Columns(i).ColumnWidth = 12
    Next i

    Cells.VerticalAlignment = xlVAlignTop
    Cells.WrapText = True
       Application.ScreenUpdating = True
End Sub



Sub a926581b()
    Dim strPattern As String
    Dim strReplace As String
    Dim regEx As Object
    Dim strInput As String
    Dim r As Range
    Dim vEnd
    Dim arr1
    
       Application.ScreenUpdating = False
    For Each r In Range("D2", Cells(Rows.count, "D").End(xlUp))
        vEnd = Range(Cells(r.row, 6), Cells(r.row, 8))
        Set regEx = CreateObject("VBScript.RegExp")
        strPattern = "\(([0-9A-Z\.]{1,})\);"
        strReplace = "@@$1@@"
        strInput = r.Value & r.Offset(0, 1).Value
      
        With regEx
            .Global = True
            .MultiLine = True
            .IgnoreCase = True
            .Pattern = strPattern
        End With

        If regEx.test(strInput) Then
           strInput = regEx.Replace(strInput, strReplace)
           arr1 = Split(strInput, "@@")
           r.Offset(0, 60).Resize(1, 3) = vEnd
           r.Resize(1, UBound(arr1)) = arr1
           
        End If
    Next
    Cells.VerticalAlignment = xlVAlignTop
    Cells.WrapText = True
    Application.ScreenUpdating = True
End Sub

 

[austlee]

Amazing!!! Great job!!!! It worked perfectly!!!

 

[Akuini]

You're welcome & thanks for the reply.