拆分一行到Excel中

Question

多行我已经制定了作为一个Excel工作表如下：

Drink  Apple Juice, Orange Juice, Coffee 
Cup  Ceramic Cup, Paper Cup, Plastic Cup, Stainless Steel Cup 

我想分裂和整理单元格值：

Drink  Apple Juice 
Drink  Orange Juice 
Drink  Coffee 
Cup  Ceramic Cup 
Cup  Paper Cup 
Cup  Plastic Cup 
Cup  Stainless Steel Cup 

非常感谢。

EDITTED

Answer 1

你可以试试这个还有：

'for getting used range in rows 
Function rngused(RowNo As Long) As Range 
Dim rngg As Range, lastcol As Range 

Set rngg = ActiveSheet.Rows(RowNo) 
Set lastcol = rngg.Find(What:="*", After:=Cells(RowNo, 1), SearchDirection:=xlPrevious) 
Set rngused = Range(Cells(RowNo, 1), Cells(RowNo, lastcol.Column)) 

Set rngg = Nothing: Set lastcol = Nothing 
End Function 

'for splitting and merging 
Sub SplitCol2Row(rngPassed As Range, offcet As Long) 
Dim i As Long, rngMerged As Range 

    For i = 2 To rngPassed.Columns.Count 
    Set rngMerged = Application.Union(rngPassed(1), rngPassed(i)) 
    rngMerged.Copy 
    Range("A" & i - 1).Offset(offcet, 0).PasteSpecial xlPasteAll 
    Next 

Set rngMerged = Nothing 
End Sub 

'main procedure 
Sub Main() 
Application.ScreenUpdating = False 
Dim rngRow As Range, lastrow As Range, ii As Long 

    For ii = 2 To 4 'these are source rows 
    Set rngRow = rngused(ii) 
    Set lastrow = Range("A:A").Find(What:="*", After:=[A1], SearchDirection:=xlPrevious) 
    SplitCol2Row rngRow, lastrow.Row 

    Application.CutCopyMode = False 
    Set rngRow = Nothing: Set lastrow = Nothing 
    Next 
Application.ScreenUpdating = False 
End Sub 

Answer 2

这个宏应该这样做就好了：

Sub SplitCellsAndExtend_New() 
'takes cells with inside line feeds and creates new row for each. 
'reverses merge into top cell. 

'turn off updates to speed up code execution 
With Application 
    .ScreenUpdating = False 
    .EnableEvents = False 
    .Calculation = xlCalculationManual 
End With 


Dim strCell As String, lastRow As Long, lRowLoop As Long, j As Long, arSplit 
Application.ScreenUpdating = False 

Const lColSplit As Long = 2 'update column number for the column that must be split 
Const sFirstCell As String = "A1" 
Dim sSplitOn As String 
sSplitOn = "," 'separating character 

lastRow = Cells(Rows.Count, lColSplit).End(xlUp).Row 

    For lRowLoop = lastRow To 1 Step -1 

     arSplit = Split(Cells(lRowLoop, lColSplit), sSplitOn) 

     If UBound(arSplit) > 0 Then 
      Rows(lRowLoop + 1).Resize(UBound(arSplit) + 1).Insert 

      Cells(lRowLoop, lColSplit).Resize(, UBound(arSplit) + 1).Value = arSplit 
      Cells(lRowLoop, lColSplit).Resize(, UBound(arSplit) + 1).Copy 
      Cells(lRowLoop + 1, lColSplit).PasteSpecial Transpose:=True 

      Cells(lRowLoop, 1).Resize(, lColSplit - 1).Copy Cells(lRowLoop + 1, 1).Resize(UBound(arSplit) + 1) 

      Rows(lRowLoop).Delete 
     End If 

     Set arSplit = Nothing 
    Next 


With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = xlCalculationAutomatic 
End With 


End Sub