VBA脚本来计算string，插入行，复制行，拆分单元格

为我提供电子表格的部门现在在我的数据库中使用了一个单元格中的多个文本。 为了链接到这些数据，我必须把它变成多行。 例如：LC123 / LC463 / LC9846需要在每一行中使用一个“LC”string复制整个行 – cell1 cell2 LC123 cell1 cell2 LC463 cell1 cell2 LC9846

我试过这两个子程序，但显然失败了

Sub InSert_Row() Dim j As Long j = InputBox(=SUM(LEN(ActiveCell)-LEN(SUBSTITUTE(ActiveCell,"LC",""))-1) ActiveCell.EntireRow.Copy ActiveCell.Offset(j).EntireRow.Insert Shift:=xlDown End Sub Sub SplitAndTranspose() Dim N() As String N = Split(ActiveCell, Chr(10)) ActiveCell.Resize(UBound(N) + 1) = WorksheetFunction.Transpose(N) End Sub 

第二个子程序将分割和复制，但不插入行，它将写入下面的行。

Answer 1

“在记忆中”的方法

根据需要插入行可能是最容易理解的，但是生成数千个单独的行插入的性能并不好。 这对一个closures（也许你只需要一次性）应该是好的，应该只需要一两分钟的时间运行，但我认为是什么，所以写了一种方法，使用集合和数组在内存中分割数据。 它将以秒为单位运行。

我已经评论了它在做什么。

 Sub ProcessData() Dim c As Collection Dim arr, recordVector Dim i As Long, j As Long Dim rng As Range Dim part, parts 'replace with your code to assign the right range etc Set rng = ActiveSheet.UsedRange j = 3 'replace with right column index, or work it out using Range.Find etc arr = rng.Value 'load the data 'Process the data adding additional rows etc Set c = New Collection For i = 1 To UBound(arr, 1) parts = Split(arr(i, j), "/") 'split the data based on "/" For Each part In parts 'loop through each "LC" thing recordVector = getVector(arr, i) 'get the row data recordVector(j) = part 'replace the "LC" thing c.Add recordVector 'add it to our results collection Next part Next i 'Prepare to dump the data back to the worksheet rng.Clear With rng.Parent .Range( _ rng.Cells(1, 1), _ rng.Cells(1, 1).Offset(c.Count - 1, UBound(arr, 2) - 1)) _ .Value = getCollectionOfVectorsToArray(c) End With End Sub 'Helper method to return a vector representing our row data Private Function getVector(dataArray, dataRecordIndex As Long) Dim j As Long, tmpArr ReDim tmpArr(LBound(dataArray, 2) To UBound(dataArray, 2)) For j = LBound(tmpArr) To UBound(tmpArr) tmpArr(j) = dataArray(dataRecordIndex, j) Next j getVector = tmpArr End Function 'Helper method to return an array from a collection of vectors Function getCollectionOfVectorsToArray(c As Collection) Dim i As Long, j As Long, arr ReDim arr(1 To c.Count, LBound(c(1), 1) To UBound(c(1), 1)) For i = 1 To c.Count For j = LBound(arr, 2) To UBound(arr, 2) arr(i, j) = c(i)(j) Next j Next i getCollectionOfVectorsToArray = arr End Function 

编辑：

替代的“范围插入”方法。

它会更慢（虽然我做了离散插入和复制操作的数量基于原来的行数，而不是一些recursion扫描，所以它不是太糟糕），但更容易理解，所以也许可以调整，如果需要。 它应该运行几分钟。

 Sub ProcessData_RangeMethod() Dim rng As Range Dim colIndex As Long Dim parts Dim currRowIndex As Long 'replace with your code to assign the right range etc Set rng = ActiveSheet.UsedRange colIndex = 3 'replace with right column index, or work it out using Range.Find etc Application.ScreenUpdating = False Application.Calculation = xlCalculationManual currRowIndex = 1 Do Until currRowIndex > rng.Rows.Count parts = Split(rng.Cells(currRowIndex, colIndex), "/") If UBound(parts) > 0 Then rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count)).Insert xlShiftDown rng.Rows(currRowIndex).Copy rng.Range(rng.Cells(currRowIndex + 1, 1), rng.Cells(currRowIndex + UBound(parts), rng.Columns.Count)) rng.Range(rng.Cells(currRowIndex, colIndex), rng.Cells(currRowIndex + UBound(parts), colIndex)).Value = Application.Transpose(parts) End If currRowIndex = currRowIndex + 1 + UBound(parts) Loop Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic End Sub