分体式眼镜

Question

5天前，我发现了编程和VBA。我完全高估了我快速掌握该学科的能力。我现在变得越来越谦虚。我对这个主题一无所知。比我想象的要大。在两三个不眠之夜之后，我决定寻求您的帮助。

我有一个包含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     |
    |--------|--------|--------|--------|---------------------------|

现在的屏幕截图 SCREEN CAPTURE OF THE SITUATION NOW 所需结果的屏幕截图 SCREEN CAPTURE OF DESIRED RESULT

Answer 1

我在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 2

因为您会笑，所以我不会向您显示代码。

Stack Overflow的任何人都不会笑或嘲笑任何OP学习和拓展视野的尝试。这个网络的存在仅仅是为了鼓励其他开发人员成为最好的，最有知识的开发人员，并提出可以帮助他们到达那里的问题。

为了帮助那些可能会帮助您的人，显示您的代码总是很有帮助的。

要继续讨论您的问题，假设您的单元格始终具有相同数量的定界符，下面的代码将完全按照您要查找的内容进行操作。

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

Answer 3

没有错误处理程序的二维数组的另一种替代方法

    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 4

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 5

分体式眼镜

调整常量部分中的值以适合您的需求。

图片

代码

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

如何将带有换行符的不同单元格的拆分循环成一个带有换行符的单元格（VBA Excel）

5 个答案:

分体式眼镜

图片

代码