Как зациклить разбиение разных ячеек с переносами строк на одну ячейку с переносами строк (VBA Excel)

Question

Я открыл для себя программирование и VBA 5 дней назад.Я полностью переоценил свои способности быстро освоить этот предмет.Я становлюсь более скромным сейчас.Я действительно ничего не знаю о предмете.Это больше, чем я думал.После двух или трех бессонных ночей я решил попросить вас о помощи.

У меня есть таблица с 5 столбцами и тысячами строк.

Для каждой строки я хотел бы разделить содержимое ячеек из столбцов A, B, C, D и объединить эти строки данных в одну ячейку в столбце E. Из того, что я понял, функция киспользование функции SPLIT - возврат каретки CHR (10) в качестве разделителя.На данный момент в ячейках столбца D нет данных.

Для каждой ячейки столбцов A, B, C и D в одной строке всегда одинаковое количество разрывов строк.Мне бы хотелось, чтобы различные строки данных из ячеек в столбцах A, B, C и D появлялись рядом, разделенные пробелом в ячейке столбца E, как показано на рисунке ниже и на прилагаемых рисунках.Очевидно, что ячейка в столбце E будет иметь такое же количество разрывов строк, что и ячейки в одной и той же строке.

Я хотел бы зациклить процесс, чтобы добиться этого для каждой строки таблицы.

Я не покажу вам свой код, потому что вы будете смеяться.

Большое спасибо за вашу помощь.

    |COLUMN A|COLUMN B|COLUMN C|COLUMN D|         COLUMN E          |
    |--------|--------|--------|--------|---------------------------|
    |afge    | dddddd | TR1TR1 | uiuiui | afge dddddd TR1TR1 uiuiui |
    |cvc     |  454   | aaaab  | Z3Z3Z3 |    cvc 454 aaab Z3Z3Z3    |    
    |15gh    | 778899 |   68C  |  ZOZO  |  15gh 778899 68C ZOZO     |
    |--------|--------|--------|--------|---------------------------|

ЭКРАН ЗАХВАТ СИТУАЦИИ СЕЙЧАС ЭКРАН Захват желаемогоРЕЗУЛЬТАТ

Answer 1

A Split Join Spectacle

Настройте значения в разделе констант в соответствии со своими потребностями.

Изображение

Код

Sub SplitJoin()

    Const cSheet As String = "Sheet1"   ' Worksheet
    Const cSource As String = "A:D"     ' Source Columns Range Address
    Const cTarget As Variant = "E"      ' Target Column Letter/Number
    Const cFirstR As Long = 2           ' First Row
    Const cSDel As String = vbLf        ' Split Delimiter
    Const cJDel As String = " "         ' Join Delimiter
    Const cRDel As String = vbLf        ' Join Row Delimiter

    Dim rngLast As Range    ' Last Cell Range in Source Range
    Dim vntAA As Variant    ' Arrays Array
    Dim vntS As Variant     ' Source Array
    Dim vntT As Variant     ' Target Array
    Dim NoR As Long         ' Number of Rows in Source Array
    Dim NoC As Long         ' Number of Columns in Source Array
    Dim i As Long           ' Source, Arrays and Target Array Row Counter
    Dim j As Long           ' Source Array Column Counter
    Dim k As Long           ' Current Split Array Row Counter
    Dim kMax As Long        ' Max Number of Elements in Current Split Array
    Dim NoCur As Long       ' Current Split Array Size (Number of Elements)
    Dim strCur As String    ' Current Split Array String
    Dim strJoin As String   ' Split Array Join String
    Dim strRow As String    ' Row Join String

    ' In Worksheet of This Workbook (i.e. Workbook Containing This Code)
    With ThisWorkbook.Worksheets(cSheet).Columns(cSource)
        ' Find Last Used Cell Range in Source Columns Range.
        Set rngLast = .Find("*", .Cells(1), xlFormulas, , xlByRows, xlPrevious)
        ' When no data is found in Source Column Range (highly unlikely).
        If rngLast Is Nothing Then Exit Sub
        ' Up a level, to Worksheets(cSheet)
        With .Parent
            ' Copy Source Range to Source Array.
            vntS = .Range(.Cells(cFirstR, .Range(cSource).Column), _
                    .Cells(rngLast.Row, .Range(cSource) _
                    .Offset(, .Range(cSource).Columns.Count - 1).Column))
        End With
    End With

    ' In Arrays
    ' Calculate Number of Rows in Source Array.
    NoR = UBound(vntS)
    ' Calculate Number of Columns in Source Array.
    NoC = UBound(vntS, 2)
    ' Resize Arrays Array to Number of Columns in Source Array. It will contain
    ' 'Split' Arrays for each cell in current row of Source Array.
    ReDim vntAA(1 To NoC)
    ' Resize Target Array to Number of Rows in Source Array, but to only one
    ' column (cTarget).
    ReDim vntT(1 To NoR, 1 To 1)
    ' Loop through rows of Source Array.
    For i = 1 To UBound(vntS)
        ' Loop through columns of Source Array.
        For j = 1 To NoC
            ' Split each cell in current row to a Split Array (vntAA(j))
            vntAA(j) = Split(vntS(i, j), cSDel)
            ' Assign size of Current Split Array to variable.
            NoCur = UBound(vntAA(j))
            ' Determine Max Number of Elements in Current Split Array.
            If NoCur > kMax Then kMax = NoCur
        Next
        ' Loop through elements of Split Array.
        For k = 0 To kMax
            ' Loop through Split Arrays.
            For j = 1 To NoC
                ' Due to the possible different sizes of the Split Arrays,
                ' error checking is necessary.
                On Error Resume Next
                ' Assign current Split Array value to a variable to 'force'
                ' error if Current Split Array Row Counter is 'out of bounds'.
                strCur = vntAA(j)(k)
                If Err Then
                    ' Reset (remove) Error.
                    On Error GoTo 0
                  Else
                    ' Check if Current Split Array String contains a value.
                    If strCur <> "" Then
                        ' Append Join Delimiter and Current Split Array String
                        ' to Split Array Join String.
                        strJoin = strJoin & cJDel & strCur
                    End If
                End If
            Next
            ' Append Join Row Delimiter and Split Array Join String to
            ' Row Join String but remove the initial (first) occurrence of
            ' the Join Delimiter (Right).
            strRow = strRow & cRDel & Right(strJoin, Len(strJoin) - Len(cJDel))
            ' Reset Split Array Join String.
            strJoin = ""
        Next
        ' Write Row Joins String to current row of Target (Source) Array, but
        ' remove the initial (first) occurrence of the Join Row Delimiter.
        vntT(i, 1) = Right(strRow, Len(strRow) - Len(cRDel))
        ' Reset Max Number of Elements in Current Split Array.
        kMax = 0
        ' Reset Row Join String.
        strRow = ""
    Next

    ' In Worksheet of This Workbook (i.e. Workbook Containing This Code)
    With ThisWorkbook.Worksheets(cSheet).Cells(cFirstR, cTarget)
        ' Copy Target Array to Target Range.
        .Resize(UBound(vntT)) = vntT
    End With

End Sub

Answer 2

Формула в E2: = CombineCells (A2: D2)

результат:

Function CombineCells(actRange As Range) As String

Dim iCt As Integer
Dim myCell As Range
Dim myArr() As String
Dim targetArr() As String
Dim mySize As Integer
Dim resultStr As String

    'Set actRange = Range("B7:D7")

    'split every cell into an array
    myArr = Split(actRange.Cells(1, 1), vbLf)
    mySize = UBound(myArr) - LBound(myArr) + 1
    ReDim targetArr(mySize)

    'copy line per line into target array
    For Each myCell In actRange
        myArr = Split(myCell, vbLf)
        Debug.Print myCell.Address
        mySize = UBound(myArr) - LBound(myArr) + 1
        'targetArr(0) = myArr(0)
        For iCt = 0 To mySize - 1
            targetArr(iCt) = targetArr(iCt) & " " & myArr(iCt)
        Next iCt
    Next myCell

    'remove leading space
    For iCt = 0 To mySize - 1
        targetArr(iCt) = Mid(targetArr(iCt), 2, Len(targetArr(iCt)) - 1)
        Debug.Print targetArr(iCt)
    Next iCt

    'copy targetArray to Cell and add LineFeed
    resultStr = targetArr(0)
    For iCt = 1 To mySize - 1
        resultStr = resultStr & vbLf & targetArr(iCt)
    Next iCt

CombineCells = resultStr
End Function

Answer 3

Я тестировал этот код на 10 строках, и он работает, как и ожидалось, но Column E нужно будет изменить размер вручную.Кажется, что Columns("E").AutoFit здесь не работает из-за присутствия Chr(10)

---

Option Explicit

Sub Test()

Dim SplitA, SplitB, SplitC, SplitD
Dim i As Long, j As Long

Dim Final As String

For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    SplitA = Split(Range("A" & i), Chr(10))
    SplitB = Split(Range("B" & i), Chr(10))
    SplitC = Split(Range("C" & i), Chr(10))
    SplitD = Split(Range("D" & i), Chr(10))

        For j = LBound(SplitA) To UBound(SplitA)
            Final = Final & SplitA(j) & Chr(32) & SplitB(j) & Chr(32) & SplitC(j) & Chr(32) & SplitD(j) & Chr(32) & Chr(10)
        Next j

        Range("E" & i) = Left(Final, Len(Final) - 2)

    SplitA = ""
    SplitB = ""
    SplitC = ""
    SplitD = ""
    Final = ""
Next i

End Sub

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

Answer 4

Другой альтернативный подход с 2D-массивом без обработчика ошибок

    Sub test()
    Dim LastRow As Long, Rw As Long, Col As Long, MaxLine As Integer, Ln As Integer
    Dim sTxt As Variant, TTxt As String, Tln As String
    Dim Ws As Worksheet
    Dim Arr() As Variant
    Set Ws = ActiveSheet  ' Change to your requirement
    LastRow = Ws.Range("A" & Rows.Count).End(xlUp).Row   ''  Change to your requirement


        For Rw = 2 To LastRow                                ''  May Change to your requirement
        TTxt = ""
        ReDim Arr(3, 0)
        MaxLine = 0
            For Col = 0 To 3                                        ''  May Change to your requirement
            sTxt = Split(Ws.Cells(Rw, Col + 1).Text, Chr(10))
            If UBound(sTxt) > MaxLine Then
                MaxLine = UBound(sTxt)
                ReDim Preserve Arr(3, MaxLine)
                End If
                For Ln = 0 To MaxLine
                    If UBound(sTxt) >= Ln Then
                    Arr(Col, Ln) = sTxt(Ln)
                    Else
                    Arr(Col, Ln) = ""
                    End If
                Next Ln
            Next Col


            For i = 0 To MaxLine
            Tln = ""
                For Col = 0 To 3
                Tln = Tln & IIf(Col = 0, "", " ") & Arr(Col, i)
                Next Col
            TTxt = TTxt & IIf(i = 0, "", Chr(10)) & Tln
            Next i
       Ws.Cells(Rw, 5).Value = TTxt
        Next Rw

'Workaround for Autofit  based on @undearboys suggest
  Ws.Range("A2:E" & LastRow).ColumnWidth = 100
  Ws.Range("A2:E" & LastRow).RowHeight = 100
 Ws.Range("A2:E" & LastRow).VerticalAlignment = xlTop
 Ws.Range("A2:E" & LastRow).Rows.AutoFit
 Ws.Range("A2:E" & LastRow).Columns.AutoFit

End Sub

Answer 5

Я не буду показывать вам свой код, потому что вы будете смеяться.

Никто в Stack Overflow никогда не будет смеяться или высмеивать попытки любого ОП узнать и расширить свой кругозор.Эта сеть существует исключительно для того, чтобы побудить других разработчиков быть лучшими, наиболее знающими разработчиками, какими они могут быть, и задавать вопросы, которые помогут им получить их.

Всегда полезно показать ваш код ради тех, ктокто может вам помочь.

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

Sub SplitContent()

Dim i As Long
Dim c As Long
Dim delim As Long
Dim dCount As Long
Dim endrow As Long
Dim txtArr

endrow = Range("A" & Rows.Count).End(xlUp).Row '<-this gets the last used row in Column A from the bottom up

For i = 2 To endrow '<- initializes loop for rows 2 to endrow
    delim = Len(Cells(i, 1)) - Len(Replace(Cells(i, 1), Chr(10), "")) '<-get the number of delimiters in the cell
    For dCount = 0 To delim '<- loop for each delimiter
        For c = 1 To 4 '<- initializes loop for columns A:D
            txtArr = Split(Cells(i, c), Chr(10)) '<-split function that you mentioned
            Range("E" & i) = Range("E" & i) & txtArr(dCount) & " " '<- let E = itself + the dCount position of the column
        Next c
        Range("E" & i) = Range("E" & i) & Chr(10) '<- add  carriage return once the column iteration has complete
    Next dCount
    Range("E" & i) = Left(Range("E" & i), Len(Range("E" & i)) - 1) '<- remove extra carriage return
Next i
End Sub

При этом, если у вас когда-либо будет разное количество разделителей, у вас будут проблемы.Вы бы хотели пойти по более динамичному маршруту и ​​включить обработчик ошибок для обработки этих случаев, а также быструю проверку, какая ячейка имеет наибольшее количество разделителей, чтобы вы не пропустили никаких данных:

Sub SplitContent()

Dim i As Long
Dim c As Long
Dim delim As Long
Dim dCount As Long
Dim endrow As Long
Dim txtArr

On Error GoTo eHandler '<- this will handle cases where the delimiter count is does not match

endrow = Range("A" & Rows.Count).End(xlUp).Row '<-this gets the last used row in Column A from the bottom up

For i = 2 To endrow '<- initializes loop for rows 2 to endrow
    For c = 1 To 4
        If Len(Cells(i, c)) - Len(Replace(Cells(i, c), Chr(10), "")) > delim Then
            delim = Len(Cells(i, c)) - Len(Replace(Cells(i, c), Chr(10), ""))  '<-get the number of delimiters in the cell
        End If
    Next c
    For dCount = 0 To delim '<- loop for each delimiter
        For c = 1 To 4 '<- initializes loop for columns A:D
            txtArr = Split(Cells(i, c), Chr(10)) '<-split function that you mentioned
            Range("E" & i) = Range("E" & i) & txtArr(dCount) & " " '<- let E = itself + the dCount position of the column
        Next c
        Range("E" & i) = Range("E" & i) & Chr(10) '<- add  carriage return once the column iteration has complete
    Next dCount
    Range("E" & i) = Left(Range("E" & i), Len(Range("E" & i)) - 1) '<- remove extra carriage return
    delim = 0
Next i

Exit Sub
eHandler:
If Err.Number = 9 Then
    Resume Next
End If
MsgBox Err.Number & vbCrLf & Err.Description
End Sub