请试试看。

Option Explicit

Sub Demo()
    Dim i As Long, j As Long, k As Integer, ColCnt As Long
    Dim arrData, rngData As Range, arrRes(), arrNum
    ' Load data from activesheet, modify as needed
    arrData = ActiveSheet.Range("A1").CurrentRegion.Value
    ColCnt = UBound(arrData, 2)
    k = 0
    ' Loop through each row
    For i = LBound(arrData) To UBound(arrData)
        ' Split by comma
        arrNum = Split(arrData(i, 2), ",")
        ' Populate the output
        For j = LBound(arrNum) To UBound(arrNum)
            k = k + 1
            ReDim Preserve arrRes(1 To ColCnt, 1 To k)
            arrRes(1, k) = arrData(i, 1)
            arrRes(2, k) = "'" & arrNum(j)
            arrRes(3, k) = arrData(i, 3)
        Next j
    Next i
    ' Write output to new sheet
    Sheets.Add
    With ActiveSheet
        .Range("A1").Resize(k, ColCnt).Value = Application.Transpose(arrRes)
    End With
End Sub

字符串

的数据

更新

• Transpose无法处理长字符串（超过255个字符）
• 很难确定输出的总行数。因此，代码将成批地将输出写入工作表。

Option Explicit

Sub Demo()
    Dim i As Long, j As Long, k As Integer, ColCnt As Long
    Dim arrData, rngData As Range, arrRes(), arrNum
    Dim desSht As Worksheet, lastCell As Range
    Const BATCH = 10000 ' Moidfy as needed
    ' Load data from activesheet, modify as needed
    arrData = ActiveSheet.Range("A1").CurrentRegion.Value
    ColCnt = UBound(arrData, 2)
    k = 0
    Set desSht = Sheets.Add
    ' Loop through each row
    ReDim arrRes(1 To BATCH, 1 To ColCnt)
    For i = LBound(arrData) To UBound(arrData)
        ' Split by comma
        arrNum = Split(arrData(i, 2), ",")
        ' Populate the output
        For j = LBound(arrNum) To UBound(arrNum)
            k = k + 1
            arrRes(k, 1) = arrData(i, 1)
            arrRes(k, 2) = "'" & arrNum(j)
            arrRes(k, 3) = arrData(i, 3)
            If k = BATCH Then
                Set lastCell = desSht.Cells(desSht.Rows.Count, 1).End(xlUp)
                If Len(lastCell) > 0 Then Set lastCell = lastCell.Offset(1, 0)
                lastCell.Resize(BATCH, ColCnt).Value = arrRes
                k = 0
                ReDim arrRes(1 To BATCH, 1 To ColCnt)
            End If
        Next j
    Next i
    ' Write output to new sheet
    Set lastCell = desSht.Cells(desSht.Rows.Count, 1).End(xlUp)
    If lastCell.Row > 1 Then Set lastCell = lastCell.Offset(1, 0)
    lastCell.Resize(BATCH, ColCnt).Value = arrRes
End Sub

型