VBA脚本可计算字符串，插入行，复制行，拆分单元格

Question

现在，向我提供要在数据库中使用的电子表格的部门在一个单元格中包含多个文本。 为了链接到该数据，我必须将其分成多行。 示例：LC123 / LC463 / LC9846需要在每一行中复制仅用一个“ LC”字符串复制的整个行-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

记忆中的方法

必要时插入行可能是最容易理解的方法，但是制作成千上万个单独的行插入的性能将不佳。 一次即可（也许只需要一次）就可以了，并且只需要花一两分钟即可运行，但是我想这到底是什么，所以写了一种使用集合和数组拆分内存中数据的方法。 它将以秒为单位运行。

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

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

编辑：

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

它将较慢（尽管我使离散插入和复制操作的数量基于原始行数，而不是基于某些递归扫描，因此也不太糟），但更易于理解，因此可以根据需要进行调整。 它应在几分钟内运行。

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