разделить данные на несколько листов

Question

У меня есть книга с более чем 100 листами, которые мне нужны для данных в ячейках «D2», «E2», «F2» и «G2», разделенных и помещенных в отдельные ячейки в этих строках.

Я просмотрел все возможные варианты в интернете.Единственное, что сработало, - это использование Kutools и разбиение данных на строки, но я бы хотел, чтобы он делал все строки одновременно, а не по одной, и, возможно, каждый лист автоматически

IЯ действительно новичок в кодировании и не знаю, куда идти.

Каждый лист представляет собой таблицу данных, в которой первая строка содержит заголовки, а вторая строка содержит данные.В столбце D - G есть информация, которая отделяется с помощью alt + enter, но я бы хотел, чтобы они теперь заполняли информацию в столбце.На некоторых листах будет только информация в D2, некоторые будут иметь информацию во всех ячейках, а некоторые не будут содержать информацию ни в одном из столбцов.

Вход 1:

Ожидаемый результат 1:

Вход 2:

Ожидаемый результат 2:

Вход 3:

Ожидаемый результат 3:

Вход 4:

Ожидаемый результат 4:

Answer 1

Со всем должным уважением и благодарностью к Dy.Lee ниже, я переработал это в это

Option Explicit
Option Base 1

Sub test()
    Dim Ws As Worksheet
    For Each Ws In Worksheets
        SplitWs2 Ws
    Next Ws
End Sub

Sub SplitWs2(Ws As Worksheet)

    ' define the input
    Dim vIN() As Variant, colIN As Integer, rowIN As Integer
    vIN = Ws.Range("a1").CurrentRegion
    'MsgBox ("ub=" & UBound(vDB, 1) & " by " & UBound(vDB, 2))  ' 4 rows by 7 columns

    ' define the output, starting out same size as input, but transposed row/column
    ' we need to add rows, and can only redim the last dimension
    Dim vOUT() As Variant, colOUT As Integer, rowOUT As Integer
    ReDim Preserve vOUT(UBound(vIN, 2), UBound(vIN, 1))

    ' step thru the input, columns and rows
    For colIN = 1 To UBound(vIN, 2)  ' to the last column
        colOUT = colIN
        rowOUT = 0

        For rowIN = 1 To UBound(vIN, 1) ' to the last row

            ' look down column at each input cell for splits
            Dim s As String, vS As Variant, k As Integer, rowAdd As Integer
            s = vIN(rowIN, colIN)
            If InStr(s, Chr(10)) Then

                vS = Split(s, Chr(10))  '  vS is base zero, so add one to UBound
                rowAdd = rowOUT + UBound(vS, 1) + 1 - UBound(vOUT, 2)
                If rowAdd > 0 Then
                    ReDim Preserve vOUT(UBound(vOUT, 1), UBound(vOUT, 2) + rowAdd)
                End If

                For k = 0 To UBound(vS)
                    rowOUT = rowOUT + 1
                    vOUT(colOUT, rowOUT) = vS(k)
                Next k

            ElseIf s > "" Then
                ' found un-split data, so move it
                rowAdd = rowOUT + 1 - UBound(vOUT, 2)
                If rowAdd > 0 Then
                    ReDim Preserve vOUT(UBound(vOUT, 1), UBound(vOUT, 2) + rowAdd) As Variant
                End If

                rowOUT = rowOUT + 1
                vOUT(colOUT, rowOUT) = s
            'Else it is blank and skip that input cell
            End If

        Next rowIN
    Next colIN
    MsgBox (Ws.Name & "  vOUT + " & UBound(vOUT, 1) & " by " & UBound(vOUT, 2))

    With Ws
        .UsedRange.Clear
        .Range("A1").Resize(UBound(vOUT, 2), UBound(vOUT, 1)) = WorksheetFunction.Transpose(vOUT)
    End With



End Sub

Answer 2

Попробуйте

Sub test()
    Dim Ws As Worksheet
    For Each Ws In Worksheets
        SplitWs Ws
    Next Ws
End Sub
Sub SplitWs(Ws As Worksheet)
    Dim vDB, rngDB As Range
    Dim vR() As Variant, vS As Variant
    Dim r As Long, i As Long, n As Long
    Dim j As Integer, k As Integer, m As Integer
    Dim c As Integer, Cnt As Integer
    Dim vRow() As Variant

    Set rngDB = Ws.Range("a1").CurrentRegion
    If rngDB.Rows.Count < 2 Then Exit Sub
    vDB = rngDB
    r = UBound(vDB, 1)
    For i = 2 To r
        k = 0
        m = 0
        '@@ The maximum value of the number of times of alt + enter
        '   used in each cell of each line is obtained.
        For j = 1 To 7
            m = m + 1
            ReDim Preserve vRow(1 To m)
            s = vDB(i, j)
            If InStr(s, Chr(10)) Then
                vS = Split(s, Chr(10))
                vRow(m) = UBound(vS)
                k = WorksheetFunction.Max(vRow)
            End If
        Next j
        n = n + k + 1
        '@@ With the array size set, only the contents of the line
        '   in which the data is located in each cell are adjusted.
        ReDim Preserve vR(1 To 7, 1 To n)
        For c = 1 To 7
            Cnt = 0
            s = vDB(i, c)
            vS = Split(s, Chr(10))
            For j = 0 To UBound(vS)
                If vS(j) <> "" Then
                    Cnt = Cnt + 1
                    vR(c, n - k - 1 + Cnt) = vS(j)
                End If
            Next j
        Next c
    Next i
    With Ws
        .UsedRange.Offset(1).Clear
        .Range("a2").Resize(n, 7) = WorksheetFunction.Transpose(vR)
    End With

End Sub