逗号分隔为多列中的行

Question

更新 - 底部的最终解决方案

我正在尝试制作这样的数据：

ID	H Column	I Column
1	bob, joe	tree, apple, dog
2	tim, tom, tum	cat

看起来像这样：

ID	H Column	I Column
1	bob	tree
1	joe	apple
1		dog
2	tim	cat
2	tom
2	tum

我确信我的代码有多个问题，但现在我专注于尝试让值在它所说的地方正确迭代 if allcount 但我感谢任何帮助！这是我的代码：

Public Function CountChrInString(Expression As String, Character As String) As Long
''
    Dim iResult As Long
    Dim sParts() As String

    sParts = Split(Expression, Character)

    iResult = UBound(sParts, 1)

    If (iResult = -1) Then
    iResult = 0
    End If

    CountChrInString = iResult

End Function

Function LastPosition(rCell As Range, rChar As String)
'This function gives the last position of the specified character
Dim rLen As Integer
rLen = Len(rCell)

For i = rLen To 1 Step -1

If Mid(rCell, i - 1, 1) = rChar Then
LastPosition = i - 1
Exit Function
End If

Next i

End Function

Sub Splt()
    Dim LR As Long, LC As Long, r As Range

    Application.ScreenUpdating = False
    LR = Cells(Rows.Count, 1).End(xlUp).Row
    LC = Cells(1, Columns.Count).End(xlToLeft).Column
    Set r = Range("H" & LR)
    Set q = Range("I" & LR)

    Do While r.Row > 1
        rcount = CountChrInString(r.Value, ",")
        qcount = CountChrInString(q.Value, ",")
        allcount = Application.WorksheetFunction.Max(rcount, qcount)

        For i = 1 To allcount
            'v = r.Value
            'pos = InStr(v, ",")
            r.EntireRow.Copy
            r.Offset(i).EntireRow.Insert
            MsgBox (r)
            If allcount > 0 Then
                r.Value = Right(r, LastPosition(r, ","))
                v = Left(r, LastPosition(r, ",") - 1)
            End If
        Next
        Set r = r.Offset(-1)
    Loop
    Application.ScreenUpdating = True
End Sub

最终解决方案 - 感谢 SJR 的帮助：

Sub RunIt()


Dim r As Long, ws As Worksheet, wsOrig As Worksheet, vH, vI, vJ, vK, vL, i As Long, j As Long, n As Long

Set wsOrig = Sheets("Paste_Here")
Set ws = Worksheets.Add

For r = 2 To wsOrig.Cells(Rows.Count, "A").End(xlUp).Row 'may need to change sheet reference

    On Error Resume Next
    vH = Split(wsOrig.Cells(r, "H"), ",")
    vI = Split(wsOrig.Cells(r, "I"), ",")
    vJ = Split(wsOrig.Cells(r, "J"), ",")
    vK = Split(wsOrig.Cells(r, "K"), ",")
    vL = Split(wsOrig.Cells(r, "L"), ",")
    
    counth = UBound(vH)
    counti = UBound(vI)
    countj = UBound(vJ)
    countk = UBound(vK)
    countl = UBound(vL)
    
    allcount = Application.WorksheetFunction.Max(counth, counti, countj, countk, countl)
    
    n = ws.Cells(Rows.Count, "A").End(xlUp).Row + 1 'whatever column has ID
    
    ws.Cells(n, "A").Resize(allcount + 1).Value = wsOrig.Cells(r, "A").Value
    ws.Cells(n, "B").Resize(allcount + 1).Value = wsOrig.Cells(r, "B").Value
    ws.Cells(n, "C").Resize(allcount + 1).Value = wsOrig.Cells(r, "C").Value
    ws.Cells(n, "D").Resize(allcount + 1).Value = wsOrig.Cells(r, "D").Value
    ws.Cells(n, "E").Resize(allcount + 1).Value = wsOrig.Cells(r, "E").Value
    ws.Cells(n, "F").Resize(allcount + 1).Value = wsOrig.Cells(r, "F").Value
    ws.Cells(n, "G").Resize(allcount + 1).Value = wsOrig.Cells(r, "G").Value
    ws.Cells(n, "M").Resize(allcount + 1).Value = wsOrig.Cells(r, "M").Value
    ws.Cells(n, "N").Resize(allcount + 1).Value = wsOrig.Cells(r, "N").Value
    
    ws.Cells(n, "H").Resize(UBound(vH) + 1).Value = Application.Transpose(vH)
    ws.Cells(n, "I").Resize(UBound(vI) + 1).Value = Application.Transpose(vI)
    ws.Cells(n, "J").Resize(UBound(vJ) + 1).Value = Application.Transpose(vJ)
    ws.Cells(n, "K").Resize(UBound(vK) + 1).Value = Application.Transpose(vK)
    ws.Cells(n, "L").Resize(UBound(vL) + 1).Value = Application.Transpose(vL)
    On Error GoTo 0
Next r

End Sub

Answer 1

认为您可以简化这一点，如下所示。这会将结果放在新工作表上，以便保留原始工作表。

在每种情况下，这都是转置和复制数组，唯一的区别是如果两个数组的大小不同，则空格的位置。进行了最低限度的测试，因此可能存在故障。

Sub x()

Dim r As Long, ws As Worksheet, vH, vI, i As Long, j As Long, n As Long

Set ws = Worksheets.Add

For r = 2 To Sheet1.Cells(Rows.Count, "H").End(xlUp).Row 'may need to change sheet reference
    vH = Split(Sheet1.Cells(r, "H"), ",")
    vI = Split(Sheet1.Cells(r, "I"), ",")
    n = ws.Cells(Rows.Count, "G").End(xlUp).Row + 1 'whatever column has ID
    If UBound(vH) >= UBound(vI) Then
        ws.Cells(n, "G").Resize(UBound(vH) + 1).Value = Sheet1.Cells(r, "G").Value
    Else
        ws.Cells(n, "G").Resize(UBound(vI) + 1).Value = Sheet1.Cells(r, "G").Value
    End If
    ws.Cells(n, "H").Resize(UBound(vH) + 1).Value = Application.Transpose(vH)
    ws.Cells(n, "I").Resize(UBound(vI) + 1).Value = Application.Transpose(vI)
Next r

End Sub