如何通过分隔符将单元格内容从多列拆分为行？

Question

我的代码从列中获取包含分隔符 (;) 的单元格，并创建新行（除列之外的所有内容都是重复的）以分隔这些值。

我有什么

我的数据中的多列需要这个，但我不希望数据重叠（例如：对于 3 列，我希望这 3 列中的每行只有一个值）。如果我可以选择多列而不是像我现在的代码那样只选择一列，那将是理想的。

我想要什么

Sub splitByCol()
    Dim r As Range, i As Long, ar
    Set r = Worksheets("Sheet").Range("J2000").End(xlUp)
    Do While r.Row > 1
        ar = Split(r.Value, "; ")
        If UBound(ar) >= 0 Then r.Value = ar(0)
        For i = UBound(ar) To 1 Step -1
            r.EntireRow.Copy
            r.Offset(1).EntireRow.Insert
            r.Offset(1).Value = ar(i)
        Next
        Set r = r.Offset(-1)
    Loop
End Sub

Answer 1

试试这个代码

Sub Test()
    Dim a, x, e, i As Long, ii As Long, iii As Long, k As Long
    a = Range("A1").CurrentRegion.Value
    ReDim b(1 To 1000, 1 To UBound(a, 2))
    For i = LBound(a) To UBound(a)
        For ii = 2 To 3
            x = Split(a(i, ii), "; ")
            For Each e In x
                k = k + 1
                b(k, 1) = k
                b(k, 2) = IIf(ii = 2, e, Empty)
                b(k, 3) = IIf(ii = 3, e, Empty)
                b(k, 4) = a(i, 4)
            Next e
        Next ii
    Next i
    Range("A5").Resize(UBound(b, 1), UBound(b, 2)).Value = b
End Sub

Answer 2

我会走这条路

Sub SplitByCol()

    With Worksheets("Sheet")
    
        With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
            
            Dim firstColValues As Variant
                firstColValues = .Value

            Dim secondColValues As Variant
                secondColValues = .Offset(, 1).Value

            Dim thirdColValues As Variant
                thirdColValues = .Offset(, 2).Value
        
            .Offset(, -1).Resize(, 4).ClearContents
            
        End With
        
        Dim iRow As Long
            For iRow = LBound(firstColValues) To UBound(firstColValues)
            
                Dim currFirstColValues As Variant
                    currFirstColValues = Split(firstColValues(iRow, 1), "; ")
                Dim currSecondColValues As Variant
                    currSecondColValues = Split(secondColValues(iRow, 1), "; ")
                    
                        With .Cells(.Rows.Count, "C").End(xlUp).Offset(1, -1)
                            With .Resize(UBound(currFirstColValues) + 1)
                                .Value = currFirstColValues
                                .Offset(, 2).Value = thirdColValues(iRow, 1)
                            End With
                        End With
                        
                        With .Cells(.Rows.Count, "B").End(xlUp).Offset(1, 1)
                            With .Resize(UBound(currSecondColValues) + 1)
                                .Value = currSecondColValues
                                .Offset(, 1).Value = thirdColValues(iRow, 1)
                            End With
                        End With
                        
            Next
            
    End With
    
End Sub

当光标位于 VBA IDE 中的任何代码行时，按 F8 逐步跟踪代码，并观察 Excel 用户界面中发生的情况

编辑

通过辅助函数添加编辑后的代码以进行更“参数化”的处理

Sub SplitByCol()

    With Worksheets("Sheet")
    
        With .Range("B2", .Cells(.Rows.Count, "B").End(xlUp))
            
            Dim firstColValues As Variant
                firstColValues = .Value
            Dim secondColValues As Variant
                secondColValues = .Offset(, 1).Value
            Dim thirdColValues As Variant
                thirdColValues = .Offset(, 2).Value
        
            .Offset(, -1).Resize(, 4).ClearContents
            
        End With
        
        Dim iRow As Long
            For iRow = LBound(firstColValues) To UBound(firstColValues)
            
                Dim currFirstColValues As Variant
                    currFirstColValues = Split(firstColValues(iRow, 1), "; ")
                Dim currSecondColValues As Variant
                    currSecondColValues = Split(secondColValues(iRow, 1), "; ")
                    
                     WriteOne .Cells(.Rows.Count, "C").End(xlUp).Offset(1), _
                               currFirstColValues, thirdColValues(iRow, 1), _
                               -1, 2
                        
                     WriteOne .Cells(.Rows.Count, "B").End(xlUp).Offset(1), _
                              currSecondColValues, thirdColValues(iRow, 1), _
                              1, 1
            Next
            
    End With
    
End Sub


Sub WriteOne(refCel As Range, _
             currMainColValues As Variant, thirdColValue As Variant, _
             mainValuesOffsetFromRefCel As Long, thirdColValuesOffsetFromRefCel As Long)

    With refCel.Offset(, mainValuesOffsetFromRefCel)
        With .Resize(UBound(currMainColValues) + 1)
            .Value = currMainColValues
            .Offset(, thirdColValuesOffsetFromRefCel).Value = thirdColValue
        End With
    End With

End Sub

Answer 3

请使用下一个代码。它使用数组，对于大范围的处理应该非常快，主要在内存中工作：

Sub testSplitInsert()
   Dim sh As Worksheet, lastR As Long, arr, arrSp, arrFin, i As Long, j As Long, k As Long
   
   Set sh = ActiveSheet
   lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
   arr = sh.Range("B1:D" & lastR).Value
   ReDim arrFin(1 To UBound(arr) * 10, 1 To 3) 'maximum to keep max 10 rows per each case
   k = 1 'initialize the variable to load the final array
   For i = 1 To UBound(arr)
        arrSp = Split(Replace(arr(i, 1)," ",""), ";") 'trim for the case when somebody used Red;Blue, instead of Red; Blue
        For j = 0 To UBound(arrSp)
            arrFin(k, 1) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
        Next j
        arrSp = Split(Replace(arr(i, 1)," ",""), ";")
        For j = 0 To UBound(arrSp)
            arrFin(k, 2) = arrSp(j): arrFin(k, 3) = arr(i, 3): k = k + 1
        Next j
   Next
   
   sh.Range("G1").Resize(k - 1, 3).Value = arrFin
End Sub

它处理“B:D”列中的范围，并在“G:I”列中返回结果。它可以很容易地适应处理任何列范围并返回甚至覆盖现有范围，但只有在检查它是否返回您需要的内容后才能这样做......