这是powerquery中的一种方式

let Source = Excel.CurrentWorkbook(){[Name="Table1"]}[Content],
#"Added Custom" = Table.AddColumn(Source, "Custom", each Table.FromColumns({Text.Split([Column3],","),Text.Split([Column4],","),Text.Split([Column5],",")})),
#"Removed Columns" = Table.RemoveColumns(#"Added Custom",{"Column3", "Column4", "Column5"}),
#"Expanded Custom" = Table.ExpandTableColumn(#"Removed Columns", "Custom", {"Column1", "Column2", "Column3"}, {"Column3", "Column4", "Column5"})
in #"Expanded Custom"

该算法将ListObject对象、放置新表的单元格以及要将其内容分成多行的列的序列号作为输入。表可以有任意多的列，还有一件事：我们要划分的单元格不必具有相同数量的元素，例如column2 a，b，c column3 a，b，c，d

Option Explicit

'this EVENT in a sheet module, call the sub with the parameters
Private Sub BT_EXPAND_Click()
   Call expand_table(Me.ListObjects("TABLEA"), Range("A8"), 3, 4, 5)
End Sub

'*******************************************************
'* COPY THIS PUBLIC FUNCTION IN A MODULE
'* CAN USE IT FOR ANY TABLE WITH ANY ROWS/COLUMNS
'* ----------------PARAMETERS--------------------
'* ListObject> the table object to expand its data
'* topLeftOfNewTable> the cell to fit the top-left corner of the new table
'* colsWithComma> ParamArray of column numbers to expand eg 3,5,6,7
'******************************************************
Public Sub expand_table(ByRef t As ListObject, topLeftOfNewTable As Range, ParamArray colsWithComma() As Variant)
   Dim rws As Long, clmns As Long, r As Long, c As Long, tex As ListObject, clarr() As Variant, strFlag As String
   Dim lbWc As Integer, ubWc As Integer, z As Integer, zidx As Integer, tmpUb As Integer, maxExp As Integer, lrw As ListRow
   Dim ccex As Integer
   
   lbWc = LBound(colsWithComma)
   ubWc = UBound(colsWithComma)
   If ubWc < 0 Then Exit Sub 'nothing todo
   
   rws = t.DataBodyRange.Rows.CountLarge
   clmns = t.DataBodyRange.Columns.CountLarge
   
   'CREATE A STRING WITH AS SPACES AS THE COLUMNS OF TABLE
   'AT POSITIONS OF colsWithComma() SET "*" (FLAG THE POSITION COLUMNS TO EXPAND)
   strFlag = Space$(clmns)
   For z = lbWc To ubWc
      Mid$(strFlag, colsWithComma(z), 1) = "*"
   Next
   
   Application.ScreenUpdating = False
   'IF ALREADY EXISTS A TABLE IN THE POSTOTION OF THE NEW, DELETE IT
   If Not topLeftOfNewTable.ListObject Is Nothing Then
      topLeftOfNewTable.ListObject.Delete
   End If
   
   'COPY THE TABLE
   't.Range.Copy topLeftOfNewTable
   Set tex = topLeftOfNewTable.Worksheet.ListObjects.Add(xlSrcRange, topLeftOfNewTable.Resize(1, t.DataBodyRange.Columns.Count), , xlYes)
   tex.Name = "TABLEA_EXP"
   t.HeaderRowRange.Copy topLeftOfNewTable
   
   'redim the array to hold the arrays of columns -to split
   ReDim clarr(lbWc To ubWc)
   
   
   For r = 1 To rws
      maxExp = 0
      For z = lbWc To ubWc
         clarr(z) = Split(t.ListRows(r).Range.Cells(, colsWithComma(z)), ",")
         tmpUb = UBound(clarr(z))
         If tmpUb > maxExp Then maxExp = tmpUb
      Next
      
      'MAYBE THE SPLITING CELLS HAVE NOT ALL THE SAME COUNT OF DATA
      'WE LOOP FROM 0 TO MAXIMUM SPLITING DATA
      For ccex = 0 To maxExp
         zidx = 0
         Set lrw = tex.ListRows.Add
         For c = 1 To clmns
            With lrw.Range.Cells(, c)
               'IF THE COLUMN HAVE TO SPLIT
               If Mid$(strFlag, c, 1) <> " " Then
                  tmpUb = UBound(clarr(zidx))
                  'IF THE ARRAY OF SPLITED VALUES EXIST AN INDEX IS IN IT'S RANGE
                  If tmpUb >= 0 And ccex <= tmpUb Then
                     'COPY THE VALUE FROM SPLITING ARRAY
                     .Value2 = clarr(zidx)(ccex)
                  End If
                  'NEXT SPLITING COLUMN
                  zidx = zidx + 1
               Else
                  'COPY THE ORIGINAL VALUE AS IS
                  .Value2 = t.ListRows(r).Range.Cells(, c)
               End If
            End With
         Next
      Next
   Next
End Sub