Excel / VBA分解字段 [英] Excel/VBA Breakdown field

问题描述

有点复杂的任务我必须做，但我会尝试和解释。我有一个excel文件，我有23000行数据导入到一个网站。每个人都有一个这样的字段：

 类别|其他数据|其他数据2 
 
食物/狗/对待预包装1223 | image.jpg 
  

我需要它抓住每一行，并为每个/ 所以把以上变成：

 类别|其他数据|其他数据2 
 
 [原始行空白] | 1223 | image.jpg 
 
食物| [空白字段] | [空白字段] 
 
食物/狗| [空白字段] | [空白字段] 
 
食物/狗/对待预包装[空白字段] | [空白字段] 
  

所以脚本需要为每个类别添加一个新行，但保留原始类别在它的前面。因此，将 category / category2 / category 3 转换为4行： [blank] - category - category / category2 - category / category2 / category 3

有没有人知道这样做的方式或脚本？

谢谢Simon， / p>

注意：工作表称为测试，类别列从E2开始，转到E23521

I有以下脚本：

  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））
使用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）
如果a（i，5）< 然后
对于每个e分割（a（i，5），/）
n = n + 1 
对于ii = 1对于UBound（a，2）
b（n，ii）= a（i，ii）
下一个
b（n，5）= Trim $（e）
下一个
如果
下一个$ 
 
 
 
 $ b $ 
这似乎是创建一个新的行，因为我需要它，但不保持斜杠结构向上移动与每一个。并且还可以在所有新添加一个空行，并使原始类别值为空。
 
 
 
解决方案：
  Sub splitEmUp（）
 Dim splitter（）As String'这是拆分函数的存储空间
 Dim i As计数器的主循环我们在
 Dim j As Integer分割器for循环计数器分割的哪一部分是
 Range（E2）。激活'从单元格e2开始，因为行1是标题和类别位于B列中
 
对于i = 0从开始到结束为24000'i = 0表示e2，i = 1表示e3 
 ActiveCell.Offset（i，0 ）.Value = Replace（ActiveCell.Offset（i，0）.Value，/，！@＃）
 splitter = Split（ActiveCell.Offset（i，0），/基于/并将其存储在分配器中的单元
 If（UBound（splitter））> 0然后'如果分裂发生
 ActiveCell.Offset（i，0）.Value ='将活动单元设置为空
 Debug.Print i 
 ActiveCell.Offset（i + 1， 0）.EntireRow.Insert shift：= xlDown，copyorigin：= xlFormatFromLeftOrAbove'插入一个新的行，并将所有内容移动到
 
 ActiveCell.Offset（i + 1，0）.Value = splitter（0）'初始化Down单元格
 ActiveCell.Offset（i + 1，0）.Value = Replace（ActiveCell.Offset（i + 1，0）.Value，！@＃，/）
对于j = 1到UBound（split）
 ActiveCell.Offset（i + j + 1）.EntireRow.Insert shift：= xlDown，copyorigin：= xlFormatFromLeftOrAbove'如果需要
创建另一行ActiveCell.Offset（i +（j + 1），0）.Value = ActiveCell.Offset（i + j）.Value& /&分配器（j）'填写新行
 ActiveCell.Offset（i +（j + 1），0）.Value = Replace（ActiveCell.Offset（i +（j + 1），0）.Value， ！@＃，/）
下一个
i = i + UBound（分割器）+ 1'需要我过去新的单元格
 ReDim分配器（0）
擦除分配器，消除分离器以避免结转。 
 
结束如果
下一个
 
 End Sub 
  
 
 
解决方案
以下是另一个解决方案的示例如何用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 
'数组输入到单独 - >应该涵盖数据的所有列+行
 arr = Range（A1：C2）
'指定哪个列具有要分割的值 - >这里是类别列
 lngSplitColumn = 2 
 
'使用给定范围的边界
'arrSum现在总是第一维的正确边界
 ReDim保存arrSum（LBound（arr，2）To UBound（arr，2），1 To 1）
 
'使用分隔的ABC创建数组ABC 
对于i = LBound（arr，1）对于UBound（arr，1）
'使用split将Foods / Dog / Treats预包装为数组，使用'\'（chr（92））作为指示符
 arrTemp = Split（arr （i，lngSplitColumn），Chr（92））
'arrTemp的每个值创建一个新行
对于j = LBound（arrTemp）到UBound（arrTemp）
'循环遍历所有输入列并创建新行
对于h = LBound（arr，2）到UBound（arr，2）
如果h = lngSplitColumn然后
'设置拆分列的值
 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食物食物/狗食/狗/对待Pre-Pack 
 next k 
 Else 
'设置任何其他列的值
 arrSum（h，UBound （arrSum，2））= arr（i，h）'set列的值h 
结束If 
下一步h 
 
 ReDim保存arrSum（LBound（arr，1）To UBound（arr，2），_ 
 LBound（arrSum，2）To（UBound（arrSum，2）+ 1））
下一个j 
下一个i 
 
 '清理最后一个空行（不需要）
 ReDim保存arrSum（LBound（arr，1）到UBound（arr，2），_ 
 LBound（arrSum，2）To（UBound（arrSum， 2） -  1））
 
'安装转置结果数组
 ReDim arrResult（LBound（arrSum，2）到UBound（arrSum，2），_ 
 LBound（arrSum，1 ）对于UBound（arrSum，1））
 
'转置数组
对于i = LBound（arrResult，1）到UBound（arrResult，1）
对于j = LBound arrResult，2）到UBound（arrResult，2）
 arrResult（i，j）= arrSum（j，i）
下一个j 
下一个i 
 
'指定目标范围
范围（单元格（1，5）单元格（UBound（arrResult，1），4 + UBound（arrResult，2）））= arrResult 
 
 End Sub 
  
您可能需要调整目标范围。
 
 
 
 单元格（1,5）  - > E1是粘贴的起点
 
Bit of a complicated task I have to do but I will try and explain. I have an excel file with 23000 lines of data which I am importing into a website. Each one has a field like so:
Category | other data | other data 2 

Foods/Dog/Treats Pre-Pack | 1223 | image.jpg
I need it to grab each line and add a new line below it for each "/" so turning the above into:
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]
So the script needs to add a new line for each category but keeping the original category in front of it. So turning category/category2/category 3 into 4 lines of: [blank] - category - category/category2 - category/category2/category 3

Does anyone know a way or script to do this?

Thanks, Simon

Note: The worksheet is called "test" and the category column starts at E2 and goes to E23521

I have the following script:
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
This seems to create a new row as I need it to but does not keep the slash structuring moving up with each one. And also dosnt add a blank line on all the new ones and make the original category value blank.

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

解决方案
Here is an example from another solution How to split cell in a row with Excel, which I modified just a tiny bit to fit your situation:
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
You might need to adapt the target range however.

Cells(1,5) -> E1 is the starting point of pasting

                        
这篇关于Excel / VBA分解字段的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！