Question

我有一本包含100多个工作表的工作簿，我需要将单元格“ D2”，“ E2”，“ F2”和“ G2”中的数据拆分并放入这些行中的各个单元格中。

我已经浏览了互联网上所有可能的选项。唯一可行的方法是使用Kutools并将数据拆分为行，但我希望它同时执行所有行，而不是一次执行，并且可能自动执行每张工作表

我对编码真的很陌生，不知道去哪里。

每张纸都是一个数据表，第一行是标题，第二行是数据。 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

在多个工作表上拆分数据

2 个答案: