Создание автоматизированной задачи для копирования данных в новую строку для каждой строки Excel

Question

У меня около 41188 строк, которые необходимо автоматически скорректировать, чтобы столбец E, который будет иметь разные значения, делился на '|'необходимо добавить в новую строку, каждая из которых содержит только одно значение.Данные из A в D и F в G должны быть скопированы в новые строки.Ниже приведен пример того, как данные сохраняются.
До

Вот как это должно быть сделано

После

Это всего лишь образец данных.В реальном документе имеется более 41188 строк, которые необходимо отрегулировать одинаково, и столбец E может иметь разные значения, которые необходимо скопировать в новые строки, поэтому создание строки должно динамически корректироваться с помощью значений, разделенныхоператором |,

Answer 1

Если вы перейдете по этой ссылке , вы увидите, что довольно легко разбить поле с несколькими значениями. Если у вас есть такие данные

Перейти к Данные / Получить данные / Из файла / Из рабочей книги и выбрать рабочую книгу со своими данными

В редакторе выберите столбец с несколькими значениями и перейдите к Преобразование

Выбрать Разделить столбец / по разделителю

Заполните поля, как на картинке. Также откройте Дополнительные параметры и измените на строк

Вот такой результат в редакторе

Перейти Домой / Закрыть и загрузить

И вы получите новый лист с данными, разделенными по полю с несколькими значениями

Answer 2

Посмотрите, делает ли этот код то, что вы хотите ...

Public Sub TransformData()
    On Error GoTo CleanUp

    Dim objSrcSheet As Worksheet, objDestSheet As Worksheet, lngEndRow As Long
    Dim lngRow As Long, rngToCopy As Range, strColToDelimit As String
    Dim strValueToDelimit As String, lngWriteRow As Long, arrValues, i As Long

    ' Change the below lines to suit your own workbook.
    Set objSrcSheet = Worksheets("Source")
    Set objDestSheet = Worksheets("Transformed")
    strColToDelimit = "E"

    objDestSheet.Cells.Clear

    lngEndRow = objSrcSheet.Cells.SpecialCells(xlCellTypeLastCell).Row

    lngWriteRow = 1

    Application.ScreenUpdating = False
    Application.EnableEvents = False

    For lngRow = 1 To lngEndRow
        Application.StatusBar = "Processing Row " & lngRow & " of " & lngEndRow & " ..."

        If lngRow Mod 500 = 0 Then DoEvents

        Set rngToCopy = objSrcSheet.Rows(lngRow)
        strValueToDelimit = objSrcSheet.Cells(lngRow, strColToDelimit)

        arrValues = Split(strValueToDelimit, "|")

        rngToCopy.Copy objDestSheet.Range("A" & lngWriteRow & ":A" & lngWriteRow + UBound(arrValues))

        For i = 0 To UBound(arrValues)
            objDestSheet.Cells(lngWriteRow, strColToDelimit) = arrValues(i)
            lngWriteRow = lngWriteRow + 1
        Next
    Next

    objDestSheet.Columns.AutoFit
    objDestSheet.Activate

CleanUp:
    Application.ScreenUpdating = True
    Application.EnableEvents = True

    Application.StatusBar = ""
End Sub

... самым большим тестом здесь будет производительность, и хотя это должно сработать, вы можете потренироваться в поиске более эффективного решения.

Вам необходимо добавить код в новый модуль в редакторе VBA и изменить значения в верхней части кода, которые указывают на имена исходного и конечного листов. Как это настроено, вам нужно создать лист с именем Преобразованный , а имя листа с исходными данными установить на Источник , вы можете изменить его на имя листа, который есть у вас в рабочей тетради.

Он ищет в столбце E значение вашего разграничения.

Просто запустите макрос из меню разработчика, как и любой другой макрос, который вы запускали ранее.

Когда он обрабатывает, вы увидите, что он обновляет в строке состояния, сколько строк он сделал и сколько он определил, что нужно будет сделать.

до вас! В любом случае стоит попробовать.

Answer 3

Так как @skin правильно подчеркивает производительность, я попробовал код с 41188 строками и числом делений столбца E на 6. На моем старом ноутбуке это занимает около 1-2 минут. В моем подходе я попытался обработать данные в массивах и скопировал их на новый лист (может изменить по вашему выбору) за один раз, чтобы обеспечить минимальный доступ к ячейкам Excel. Массив был транспонирован кодом как транспонирующий массив с использованием WorksheetFunction, может иметь ограничение . Как я лично использовал, чтобы не вести расчеты, обновление экрана, отключение событий, я не привык к тому же в пробной версии. это может быть использовано для дальнейшей оптимизации кода.

Код:

Sub test()
tm = Timer
Dim SrcArr As Variant, TrgArr As Variant, LastRow As Long
Dim EcolVal As Variant, itm As Long, NewRw As Long
Dim Ws As Worksheet
Dim i As Long, n As Long

ReDim TrgArr(1 To 7, 0)
LastRow = ThisWorkbook.Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
SrcArr = ThisWorkbook.Sheets("Sheet1").Range("A1:G" & LastRow).Value
NewRw = 0
    For rw = LBound(SrcArr, 1) To UBound(SrcArr, 1)
    EcolVal = Split(SrcArr(rw, 5), "|")

        If UBound(EcolVal) <= 0 Then
        NewRw = NewRw + 1
        ReDim Preserve TrgArr(1 To 7, NewRw)
            For i = 1 To 7
            TrgArr(i, NewRw) = SrcArr(rw, i)
            Next
        Else
            For itm = LBound(EcolVal) To UBound(EcolVal)
            NewRw = NewRw + 1
            ReDim Preserve TrgArr(1 To 7, NewRw)
                For i = 1 To 7
                    If i = 5 Then
                    TrgArr(i, NewRw) = EcolVal(itm)
                    Else
                    TrgArr(i, NewRw) = SrcArr(rw, i)
                    End If
                Next
            Next
        End If
    Next


Dim TrgArr2 As Variant
    ReDim TrgArr2(1 To UBound(TrgArr, 2), 1 To UBound(TrgArr, 1))
    For i = 1 To UBound(TrgArr, 2)
        For n = 1 To UBound(TrgArr, 1)
            TrgArr2(i, n) = TrgArr(n, i)
        Next
    Next

 Set Ws = ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count))
 Ws.Range("A1").Resize(UBound(TrgArr2, 1), UBound(TrgArr2, 2)).Value = TrgArr2
Debug.Print Timer - tm
End Sub