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
有没有人知道一个方法或脚本来做到这一点？
谢谢，西蒙
注意：工作表被称为“testing”，类别列从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
这是我想出来的。 一定要更改表格名称以适合您的工作簿。 另外一定要改变input范围以适合您自己的单元格input范围。
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
这里是另一个解决scheme的例子如何用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 ABC 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是粘贴的起点