Excel VBA to split / format data vertically - excel

Question

I am trying to format and split a column of excel cells vertically. Each cell contains starts ICD-10: and then lots of codes separated with commas ",". I would like to Removed the ICD-10: and all of the spaces resulting in a column of just the individual codes. I found the following VBA code and have modified it to partly. I need to help removing the unwanted spaces and "ICD-10:" from the out put. I tried using trim and replace but I don't have a super firm understanding of exactly how this is working I just know it is close.
Any help is greatly appreciated.
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
If xStr = "" Then
xStr = xCell.Value
Else
xStr = xStr & "," & xCell.Value
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub
Sample Data
A1 = ICD-10: S7291XB, I4891, S0101XA, S7291XB, Z7901, V0300XA
A2 = ICD-10: S72431C, D62, E0590, E43, E785, E872, F321, G4700, I129, I2510, I441, I4891, I4892, I959, N183, R339, S0101XA, S01111A, S32591A, S7010XA, S72431C, Z6823, Z7901, Z87891, Y92481, S72351B
Thanks for the help.

Answer 1

You have a very good beginning. With only 3 more lines of code, we can make it happen. I don't know what happens then the output range xOutRg is more than one cell.
Option Explicit ' ALWAYS
Sub splitvertically()
'updatebyExtendoffice
Dim xRg As Range
Dim xOutRg As Range
Dim xCell As Range
Dim xTxt As String
Dim xStr As String
Dim xOutArr As Variant
On Error Resume Next
xTxt = ActiveWindow.RangeSelection.Address
Set xRg = Application.InputBox("please select the data range:", "Kutools for Excel", xTxt, , , , , 8)
If xRg Is Nothing Then Exit Sub
Set xOutRg = Application.InputBox("please select output cell:", "Kutools for Excel", , , , , , 8)
If xOutRg Is Nothing Then Exit Sub
For Each xCell In xRg
'just get the input value(s), then remove ICD-10, then remove any spaces
xTxt = xCell.Value
xTxt = Replace(xTxt, "ICD-10:", "")
xTxt = Replace(xTxt, " ", "")
' then append xTxt (not original cell)
If xStr = "" Then
xStr = xTxt
Else
xStr = xStr & "," & xTxt
End If
Next
xOutArr = VBA.Split(xStr, ",")
xOutRg.Range("A1").Resize(UBound(xOutArr) + 1, 1) = Application.WorksheetFunction.Transpose(xOutArr)
End Sub

Answer 2

Here's code that will split the cells in the way you describe. It works very fast but please take the time to read all the comments carefully. Some of them are just informative but others may require your action. In this regard, pay attention to the names I have given to the variables. A name like FirstDataRow will help you know what you should adjust.
Sub SplitCellsToList()
Const FirstDataRow As Long = 2 ' change to suit
Const InputColumn As Long = 1 ' change to suit (1 = column A)
Dim OutCell As Range ' first cell of output list
Dim InArr As Variant ' array of input values
Dim OutArr As Variant ' array of output values
Dim n As Long ' row index of OutArr
Dim Sp() As String ' Split cell value
Dim i As Integer ' index of Split
Dim R As Long ' loop counter: sheet rows
Set OutCell = Sheet1.Cells(2, "D") ' change to suit
With ActiveSheet
InArr = .Range(.Cells(FirstDataRow, InputColumn), _
.Cells(.Rows.Count, InputColumn).End(xlUp)).Value
End With
ReDim OutArr(1 To 5000) ' increase if required
' 5000 is a number intended to be larger by a significant margin
' than the total number of codes expected in the output
For R = 1 To UBound(InArr)
Sp = Split(InArr(R, 1), ":")
If UBound(Sp) Then
Sp = Split(Sp(1), ",")
For i = 0 To UBound(Sp)
Sp(i) = Trim(Sp(i))
If Len(Sp(i)) Then
n = n + 1
OutArr(n) = Sp(i)
End If
Next i
Else
' leave the string untreated if no colon is found in it
n = n + 1
OutArr(n) = InArr(R, 1)
End If
Next R
If n Then
ReDim Preserve OutArr(1 To n)
OutCell.Resize(n).Value = Application.Transpose(OutArr)
End If
End Sub