Excel/VBA 细分字段

我必须完成一项复杂的任务，但我会尝试解释。我有一个包含 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

有谁知道执行此操作的方法或脚本？

谢谢，西蒙

注意：该工作表称为“测试”，类别列从 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

这似乎根据我的需要创建了一个新行，但并没有使斜杠结构与每个行一起向上移动。并且不要在所有新类别上添加空行并使原始类别值留空。

SOLVED:

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

这就是我想出来的。请务必更改工作表名称以适合您的工作簿。另请务必更改输入范围以适合您自己的单元格输入范围。

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