Разделить столбец Excel и скопировать данные в новую строку

Question

У меня есть электронная таблица с 20 тыс. Записей. Он содержит столбцы 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

Вы можете изменить рабочий диапазон на

1. изменение исходного макета данных в этой строке Range([a1], Cells(Rows.Count, "e").End(xlUp)).Value2 (в настоящее время устанавливается A: E)
2. выберите, какой из столбцов разделить из диапазона в (1) с этой строкой arrVar = Split(X(lngRow, 3), " £ ") (в настоящее время разделяет третий столбец)
3. согласно (2) обновить столбец для разделения в этой строке кода Y(3, lngCnt) = arrVar(lngCol) (в настоящее время разделяет третий столбец)

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