Question

我有一个包含20k记录的电子表格。它包含列A - J.列D有多个以£分隔的条目。我想将D列数据与A-C和E-J列中的数据一起分成多行。

输入：

Blue    Long    Car £ Motorcycle £ Skateboard   Hard    Hazel  
Green   Short   House £ Motel                   Soft    Pink  
Red     Hot     Room £ Yard £ Fort £ Castle     Medium  Yellow

输出：

Blue    Long    Car         Hard    Hazel  
Blue    Long    Motorcycle  Hard    Hazel  
Blue    Long    Sketeboard  Hard    Hazel  
Green   Short   House       Soft    Pink  
Green   Short   Motel       Soft    Pink  
Red     Hot     Room        Medium  Yellow  
Red     Hot     Yard        Medium  Yellow  
Red     Hot     Fort        Medium  Yellow  
Red     Hot     Casle       Medium  Yellow

非常感谢您的帮助！

干杯，

杰克

Answer 1

如果您的初始数据位于A：E列，并且C中有“£”列，则此代码将拆分并转储到单元格H1

您可以通过

改变工作范围

更改此行中的初始数据布局Range([a1], Cells(Rows.Count, "e").End(xlUp)).Value2（目前设置A：E）
使用此行arrVar = Split(X(lngRow, 3), " £ ")选择要从（1）中的范围拆分的列（当前拆分第三列）
按照（2）更新要在此代码行Y(3, lngCnt) = arrVar(lngCol)中拆分的列（当前拆分第三列）

sample

Option Base 1
Sub SplitEm()
    Dim lngRow As Long
    Dim lngCol As Long
    Dim lngCnt As Long
    Dim lngRecord As Long
    Dim X
    Dim Y()
    Dim arrVar() As String

    X = Range([a1], Cells(Rows.Count, "e").End(xlUp)).Value2
    'Use a tranposed array to store the results so that the 2nd dimension can be resized very 1000 records
    ReDim Y(5, 1000)

    For lngRow = 1 To UBound(X, 1)
        'Split middle column by " £ "
        arrVar = Split(X(lngRow, 3), " £ ")
        For lngCol = LBound(arrVar) To UBound(arrVar)
            lngCnt = lngCnt + 1
            'redim storage array if needed
            If lngCnt Mod 1000 = 0 Then ReDim Preserve Y(5, UBound(Y, 2) + 1000)
            'dump 5 new records
               For lngRecord = 1 To UBound(X, 2)
                    Y(lngRecord, lngCnt) = X(lngRow, lngRecord)
            Next
            'update record 3 with the split text
            Y(3, lngCnt) = arrVar(lngCol)
        Next lngCol
    Next lngRow
    [h1].Resize(UBound(Y, 2), UBound(Y, 1)).Value2 = Application.Transpose(Y)
End Sub

Answer 2

这是一个按指定方式拆分数据的方法。代码中使用变量来设置范围，因此可以根据需要进行更改

Sub SplitData()
    Dim ws As Worksheet
    Dim rng As Range
    Dim data As Variant
    Dim dataSplit() As Variant
    Dim i As Long, j As Long, k As Long, n As Long
    Dim col As Long, cols As Long
    Dim rws() As String
    Dim addr As String
    Dim rw As Long

    cols = 10 ' Column J
    col = 4 'column D

    'Assuming the active shsets contains the data
    Set ws = ActiveSheet

    ' Assuming data starts in A1 and column A is contiguous
    Set rng = ws.Range(ws.Cells(1, cols), ws.[A1].End(xlDown))

    ' Get data into an array
    data = rng
    j = 1

    ' Count number of £ in data
    addr = rng.Columns(col).Address
    rw = Evaluate("=SUM(LEN(" & addr & ")-LEN(SUBSTITUTE(" & addr & ",""£"","""")))")

    ' Size destination array
    ReDim dataSplit(1 To UBound(data, 1) + rw, 1 To cols)

    For i = 1 To UBound(data, 1)
        ' if contains £ then split it
        If InStr(data(i, col), "£") > 0 Then
            ' copy several rows into destination array
            rws = Split(data(i, col), "£")
            For n = 0 To UBound(rws)
                For k = 1 To cols
                    dataSplit(j + n, k) = data(i, k)
                Next
                dataSplit(j + n, col) = Trim(rws(n))
            Next
            j = j + UBound(rws) + 1
        Else
            ' copy one row into destination array
            For k = 1 To cols
                dataSplit(j, k) = data(i, k)
            Next
            j = j + 1
        End If
    Next

    ' put resut back into sheet
    rng.Resize(UBound(dataSplit, 1), cols) = dataSplit

End Sub

拆分Excel列并将数据复制到新行

2 个答案: