我必须做一些复杂的任务，但我会尝试解释。我有一个包含23000行数据的excel文件，我将其导入到网站中。每个人都有一个像这样的字段：
Category | other data | other data 2
Foods/Dog/Treats Pre-Pack | 1223 | image.jpg
我需要它抓住每一行并在其下面为每个“/”添加一个新行，以便将上述内容转换为：
Category | other data | other data 2
[blank in original line] | 1223 | image.jpg
Foods | [blank field] | [blank field]
Foods/Dog | [blank field] | [blank field]
Foods/Dog/Treats Pre-Pack | [blank field] | [blank field]
因此脚本需要为每个类别添加一个新行，但保留原始类别。因此，将category/category2/category 3转换为4行：[blank] - category - category/category2 - category/category2/category 3
有没有人知道这样做的方式或脚本？
谢谢，西蒙
注意：工作表名为“test”，类别列从E2开始，转到E23521
我有以下脚本：
Sub test()
Dim a, i As Long, ii As Long, e, n As Long
Dim b(), txt As String, x As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(5).Value))
With CreateObject("VBScript.RegExp")
.Global = True
.Pattern = "/"
x = .Execute(txt).Count * 2
End With
ReDim b(1 To UBound(a, 1) + x, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
If a(i, 5) <> "" Then
For Each e In Split(a(i, 5), "/")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 5) = Trim$(e)
Next
End If
Next
.Resize(n).Value = b
End With
End Sub
这似乎创建了一个新行，因为我需要它，但不会使斜杠结构向上移动。并且dosnt在所有新的行上添加一个空行，并将原始类别值设为空白。
解决：
Sub splitEmUp()
Dim splitter() As String 'this is storage space for the split function
Dim i As Integer ' main-loop for counter "which cell we are on"
Dim j As Integer ' splitter for-loop counter "which section of the split are we on"
Range("E2").Activate 'starting in cell e2 because row 1 is headers and category is located in the B column
For i = 0 To 24000 'from beginning to end i=0 means e2, i=1 means e3
ActiveCell.Offset(i, 0).Value = Replace(ActiveCell.Offset(i, 0).Value, " / ", "!@#")
splitter = Split(ActiveCell.Offset(i, 0), "/") 'split the cell based on / and store it in splitter
If (UBound(splitter)) > 0 Then 'if a split occurred
ActiveCell.Offset(i, 0).Value = "" 'set the activecell to blank
Debug.Print i
ActiveCell.Offset(i + 1, 0).EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove 'insert a new row and shift everything down
ActiveCell.Offset(i + 1, 0).Value = splitter(0) 'initialize the "Down" cells
ActiveCell.Offset(i + 1, 0).Value = Replace(ActiveCell.Offset(i + 1, 0).Value, "!@#", " / ")
For j = 1 To UBound(splitter)
ActiveCell.Offset(i + j + 1).EntireRow.Insert shift:=xlDown, copyorigin:=xlFormatFromLeftOrAbove 'create another row if it needs to
ActiveCell.Offset(i + (j + 1), 0).Value = ActiveCell.Offset(i + j).Value & "/" & splitter(j) 'fill out the new row
ActiveCell.Offset(i + (j + 1), 0).Value = Replace(ActiveCell.Offset(i + (j + 1), 0).Value, "!@#", " / ")
Next
i = i + UBound(splitter) + 1 'need to step I past the new cells
ReDim splitter(0)
Erase splitter 'erase and eliminate splitter to avoid carry over.
End If
Next
End Sub
答案 0 :(得分：0)
这就是我想出的。请务必更改工作表名称以适合您的工作簿。还要确保更改输入范围以适合您自己的输入单元格范围。
Function SplitAndWrite(inputCell As Range, TopOfOutputRange As Range, sep As String) As Range
Dim texts() As String, i As Integer, outputText As String
texts = Split(inputCell.Value, sep)
outputText = ""
TopOfOutputRange = "" 'your blank line
For i = LBound(texts) To UBound(texts)
outputText = outputText & sep & texts(i)
TopOfOutputRange.Offset(i + 1) = outputText
Next i
Set SplitAndWrite = TopOfOutputRange.Offset(UBound(texts) + 1)
End Function
Sub THEPOPULATOR()
Dim s3 As Worksheet, s4 As Worksheet
Set s3 = Sheets("Sheet1")
Set s4 = Sheets("Sheet2")
Dim inputrange As Range, c As Range, outputrange As Range
Set outputrange = s4.Range("A1")
Set inputrange = s3.Range(s3.Cells(2, 1), s3.Cells(2, 1).End(xlDown)) 'cells(2,1) = "A1". change this to your top input cell. then the second half will find the bottom cell on its own. This is the same as pressing Ctrl+down
For Each c In inputrange
s3.Range(c.Offset(0, 1), c.Offset(0, c.End(xlToRight).Column)).Copy outputrange.Offset(1, 1)
Set outputrange = SplitAndWrite(c, outputrange.Offset(1), "/")
Next c
End Sub
答案 1 :(得分：0)
以下是另一个解决方案How to split cell in a row with Excel的示例，我只修改了一小部分以适应您的情况：
Public Sub solutionJook()
Dim arr() As Variant
Dim arrSum() As Variant
Dim arrResult() As Variant
Dim arrTemp As Variant
Dim i As Long
Dim j As Long
Dim h As Long
Dim lngSplitColumn As Long
'input of array to seperate -> should cover all columns+rows of your data
arr = Range("A1:C2")
'specify which column has the values to be split up -> here this is the category column
lngSplitColumn = 2
'using the boundries of the given range,
'arrSum has now always the right boundries for the first dimension
ReDim Preserve arrSum(LBound(arr, 2) To UBound(arr, 2), 1 To 1)
'create the array with seperated A B C
For i = LBound(arr, 1) To UBound(arr, 1)
'use split to make Foods/Dog/Treats Pre-Pack into an array, using '\' (chr(92)) as indicator
arrTemp = Split(arr(i, lngSplitColumn), Chr(92))
'every value of arrTemp creates a new row
For j = LBound(arrTemp) To UBound(arrTemp)
'loop through all input columns and create the new row
For h = LBound(arr, 2) To UBound(arr, 2)
If h = lngSplitColumn Then
'setup the value of the splitted column
Dim k as long
arrSum(h, UBound(arrSum, 2)) = arrTemp(LBound(arrTemp))
for k = LBound(arrTemp)+1 to j
arrSum(h, UBound(arrSum, 2)) = arrSum(h, UBound(arrSum, 2)) & "\" & arrTemp(k) 'set Foods Foods/Dog Foods/Dog/Treats Pre-Pack
next k
Else
'setup the value of any other column
arrSum(h, UBound(arrSum, 2)) = arr(i, h) 'set Value of Column h
End If
Next h
ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
LBound(arrSum, 2) To (UBound(arrSum, 2) + 1))
Next j
Next i
'clean up last empty row (not realy necessary)
ReDim Preserve arrSum(LBound(arr, 1) To UBound(arr, 2), _
LBound(arrSum, 2) To (UBound(arrSum, 2) - 1))
'setup transposed result array
ReDim arrResult(LBound(arrSum, 2) To UBound(arrSum, 2), _
LBound(arrSum, 1) To UBound(arrSum, 1))
'transpose the array
For i = LBound(arrResult, 1) To UBound(arrResult, 1)
For j = LBound(arrResult, 2) To UBound(arrResult, 2)
arrResult(i, j) = arrSum(j, i)
Next j
Next i
'specify target range
Range(Cells(1, 5), Cells(UBound(arrResult, 1), 4 + UBound(arrResult, 2))) = arrResult
End Sub
然而，您可能需要调整目标范围。
Cells(1,5) - ＆gt; E1是粘贴的起点