1

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

这似乎根据我的需要创建了一个新行，但不会使斜线结构随着每个行向上移动。并且不要在所有新的上添加一个空行并将原始类别值设为空白。

解决了：

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
4

2 回答 2

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
于 2012-10-29T17:34:30.217 回答
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)-> E1是粘贴的起点

于 2012-10-29T17:39:44.543 回答