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

Question

我正在尝试设置一列excel单元格的格式并垂直拆分。每个单元格包含开始的ICD-10：，然后是许多用逗号"，“分隔的代码。我想删除ICD-10:和所有空格，结果只有一列单独的代码。我找到了下面的VBA代码，并将其修改为部分。我需要帮助从输出中删除不需要的空格和"ICD-10:“。我尝试过使用trim和replace，但我对它的工作原理并不是很了解，我只知道它很接近。

任何帮助都是非常感谢的。

​

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，S01111A，，

谢谢你的帮助。

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