拆分单元格string以使用这些部分创build两行

我有一个格式大致如下的数据集：

…/数据/…
猫/ 1763 / 9.4 + 5.6 /快乐
…/数据/…

我想要做的是用连接的数字将列分列，然后将它们分开。 9.4和5.6，并创build两个相邻的行，其他所有数据相同：

…/数据/…
猫/ 1763 / 9.4 /快乐
猫/ 1763 / 5.6 /快乐
…/数据/…

通过几千行而不是所有这些都被连接起来。

我已经做了一些尝试，但虽然单个组件似乎工作（在不抛出语法错误的意义上）整体没有。 有任何想法吗？

主要的function是'plusinsert'，它从一个下拉表中取出一个string来定位一个特定的工作表。 它从各种论坛片段拼凑在一起，希望我可以信任原作者，但我没有得到的名字。

Sub CopyR() Dim cl As Range Dim r As Long Set cl = ActiveCell r = cl.Row Range("a" & r, Range("CQ" & r)).Copy End Sub Function Extractparts(path As String) Dim parts parts = Split(path, "+") Extract1 = parts(1) Extract2 = parts(2) End Function Public Sub plusinsert(name As String) Dim Target2, cell As Range Dim cellvalue As String ActiveWorkbook.Sheets(name).Activate Set Target2 = ActiveSheet.Range(Range("G1"), Range("D65536").End(xlUp)) For Each cell In Target2 If cell.CountIf(cell, "*+*") Then cellvalue = cell.Value: Extractparts (cellvalue): CopyR: ActiveSheet.Paste: Application.CutCopyMode = False: cell.Value = Extract1: cell.Offset(1, 0).Value = Extract2 Next cell End Sub 

对于列中的数据，我使用下面的代码解决了这个问题：

 Dim Target, cell, RowRange As Range Dim cellvalue As String Dim Count As Integer ' Snippet target range, is for whole column in production. Set Target = Range("G2:G8") Dim TestArray() As String For Each cell In Target TestArray() = Split(cell.Value, "+"): cell.Value = TestArray(0) If UBound(TestArray) > 0 Then Set RowRange = cell.EntireRow: RowRange.Copy: RowRange.Insert Shift:=xlUp: Application.CutCopyMode = False: cell.Value = TestArray(1) End If Next cell 

Answer 1

注意 »注释掉的部分，你可以调整你的Column ， firstDataRow ， deli和delim设置

假设您的数据全部放在列A ; 你的工作表看起来像这样：

你运行这个代码

 Option Explicit Sub SplitingAndInserting() Dim ws As Worksheet, rng As Range Dim i&, deli$, delim$, urColumn$, firstDataRow& ' setters ' modify them if you need to Set ws = Sheets("Sheet1") urColumn = "A" firstDataRow = 1 deli = "+" delim = "/" For i = ws.Range(urColumn & Rows.Count).End(xlUp).Row To firstDataRow Step -1 Set rng = ws.Range(urColumn & i) If InStr(1, rng.Value, deli, vbTextCompare) Then Dim var As Variant var = Split(rng.Value, deli) If UBound(var) > 0 Then ws.Rows(i + 1 & ":" & i + 1).Insert Shift:=xlDown Dim j& Dim fpart As String fpart = var(0) Dim spart As String spart = var(1) For j = 1 To Len(spart) If StrComp(delim, Left(Right(spart, j), 1), vbTextCompare) = 0 Then fpart = fpart + Right(spart, j) Exit For End If Next j rng = fpart fpart = var(0) For j = 1 To Len(fpart) If StrComp(delim, Left(Right(fpart, j), 1), vbTextCompare) = 0 Then spart = Left(fpart, Len(fpart) - (j - 1)) & spart Exit For End If Next j rng.Offset(1, 0) = spart End If End If Set rng = Nothing Next i End Sub 

得到像这样的结果：