Question

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

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

1 个答案: