Excel VBA以垂直拆分/格式化数据

Question

我正在尝试垂直格式化和拆分一列excel单元格。每个单元格包含起始ICD-10：然后是用逗号分隔的许多代码"&"；。我想删除ICD-10:和所有导致一列仅包含单个代码的空格。我找到了以下VBA代码，并将其部分修改为。我需要帮助去除不需要的空间；ICD-10："；从输出。我试过使用修剪和更换，但我对它的确切工作原理没有非常确切的了解，我只知道它很接近。

非常感谢您的帮助。

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

样本数据

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、s0111a、S32591A、S7010XA、S72431C、Z6823、Z7901、Z87891、Y92481、S72351B

谢谢你的帮助。

Answer 1

你有一个非常好的开始。只需再增加3行代码，我们就可以实现这一目标。我不知道当输出范围xOutRg超过一个单元格时会发生什么。

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

下面的代码将按照您描述的方式拆分单元格。它运行得很快，但请花时间仔细阅读所有评论。其中一些只是提供信息，但另一些可能需要你采取行动。在这方面，请注意我给变量起的名字。像FirstDataRow这样的名称将帮助您知道应该调整什么。

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