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

Answer 3

嘿，您可以在1以下使用它-肯定会起作用

      Sub splitbyRow()
      Dim R as Range, I as Long, at
      Set R =worksheet ("sheetName").Range("column- 
        A/B/C99999").End(xlUp)

      Do while R.Row>1
           ar = Split(R.Value, ",") # "," delimiter- change 
                                                      whichever you prefer

           IfUBound(ar) >=0 then R.value =at(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

如果要从“ ar = split .....”到“下一步”复制多个定界符，请将其粘贴到“ Set R .....”上方，然后更改所需的定界符

在excel中将一行拆分为多行

3 个答案: