Vba 拆分单元格并将其内容一个单元格插入另一个单元格之上

我正在尝试编写一个VBA命令，以便拆分单元格内容并插入其中包含的所有内容，一个单元格位于另一个单元格之上

Sub SplitInsert()

Dim Cell As Variant
Dim Cell1 As Variant
Dim i As Integer

'Input column is on column A that I manually select'
'Then I press plau'

For Each Cell In Selection
    'I split the current selected cell into a variant tab'
    Cell1 = Split(Cell.Value)

    'Then I do a second loop to insert every Cell1 values'
    'one after the other in column B'
    For i = 0 To UBound(Cell1)
        'I don't know how to insert and shift down just a cell,'
        'and not a row or a column'
        Cells(2, 1).Insert '....' shift:=xlShiftDown
    Next
Next Cell
End Sub

输入：

• 德斯蒙德·休谟·杰克·谢泼德
• 凯特·奥斯汀
• 约翰·洛克·詹姆斯·福特·雨果·雷耶斯

将成为

输出：

• 雨果·雷耶斯
• 詹姆斯·福特
• 约翰·洛克
• 凯特·奥斯汀
• 杰克·谢泼德
• 德斯蒙德·休谟

谢谢你的帮助：）

尝试一下，根据你的需要调整一下。我对你的代码做了一些修改，但你走对了路

将单元格从变体更改为范围

在

Cell1=Split（Cell.Value）

行中，您忘记了第二个 该方法的参数。我添加了它，比如

Cell1=Split（Cell.Value，
“-”

最后使用

单元格（1，2）。Value=Cell1（i）

调用数组 价值观

尝试一下，根据你的需要调整一下。我对你的代码做了一些修改，但你走对了路

将单元格从变体更改为范围

在

Cell1=Split（Cell.Value）

行中，您忘记了第二个 该方法的参数。我添加了它，比如

Cell1=Split（Cell.Value，
“-”

最后使用

单元格（1，2）。Value=Cell1（i）

调用数组 价值观

---

我没有完全理解你所说的“一个细胞高于另一个细胞”的意思。所以也许Foxfire和Burns和Burns会按照你的意愿来回答。 我的代码将在B中插入结果，并在输出中插入一行以获得结构化视图。我还更改了代码中的一些内容，并尝试在代码后面添加注释，以便更好地理解它的功能

Sub SplitInsert()
Dim Cell As Variant
Dim Cell1 As Variant
Dim i As Integer, j As Integer
Dim rng As Range
    Set rng = Selection                   ' get selection range
    j = Selection.Row                     ' get first selected row
    For Each Cell In rng                  ' perform for each on every cell in range
    Cell1 = Split(Cell.Value, "-")        ' added separator (I assume it's what you'd want to split?)

        For i = 0 To UBound(Cell1)
            If i > 0 Then Rows(j).Insert  ' only insert line if it's not the first value
            Cells(j, 2).Value = Cell1(i)  ' insert value in B
            j = j + 1                     ' increase row counter
        Next i
    Next Cell
End Sub

---

我没有完全理解你所说的“一个细胞高于另一个细胞”的意思。所以也许Foxfire和Burns和Burns会按照你的意愿来回答。 我的代码将在B中插入结果，并在输出中插入一行以获得结构化视图。我还更改了代码中的一些内容，并尝试在代码后面添加注释，以便更好地理解它的功能

Sub SplitInsert()
Dim Cell As Variant
Dim Cell1 As Variant
Dim i As Integer, j As Integer
Dim rng As Range
    Set rng = Selection                   ' get selection range
    j = Selection.Row                     ' get first selected row
    For Each Cell In rng                  ' perform for each on every cell in range
    Cell1 = Split(Cell.Value, "-")        ' added separator (I assume it's what you'd want to split?)

        For i = 0 To UBound(Cell1)
            If i > 0 Then Rows(j).Insert  ' only insert line if it's not the first value
            Cells(j, 2).Value = Cell1(i)  ' insert value in B
            j = j + 1                     ' increase row counter
        Next i
    Next Cell
End Sub

---

读/写工作表需要很多时间。对于小列表来说不是问题，但对于大列表来说可能是问题

下面的代码避免了这种情况

• 将源数据读入变量数组
• 拆分每个项目并按顺序输入到集合对象中
• 创建结果数组并按相反顺序从集合中填充
• 将结果数组写回工作表

---

---

读取/写入工作表需要很多时间。对于小列表来说不是问题，但对于大列表来说可能是问题

下面的代码避免了这种情况

• 将源数据读入变量数组
• 拆分每个项目并按顺序输入到集合对象中
• 创建结果数组并按相反顺序从集合中填充
• 将结果数组写回工作表

---

Option Explicit
Sub SplitNames()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim cNames As Collection
    Dim V As Variant
    Dim I As Long, J As Long

'Set results and source worksheets and ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet1")
    Set rRes = wsRes.Cells(1, 5)

'read source data into array
'you could use  vSrc=Selection  instead of determining the range as below
'the code below assumes the data is in column A starting at A1
With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'split the names and read them into collection
Set cNames = New Collection
For I = 1 To UBound(vSrc, 1)
    V = Split(vSrc(I, 1), "-")
    For J = 0 To UBound(V)
        cNames.Add V(J)
    Next J
Next I

'create results array in reverse order
ReDim vRes(1 To cNames.Count, 1 To 1)
For I = 1 To cNames.Count
    vRes(cNames.Count + 1 - I, 1) = cNames(I)
Next I

'write the results
Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With

End Sub