Combining Value in Selected Range Using VBA-CodePudding

I'm new here. I want your help to combine the value of two selected rows. First, I will select 2 rows that contain value in each cell. I want each value in the cell of the second row move to the cell in the first row, then the cell in the second row will be empty. I've tried one VBA, but the result makes all the text combined into one cell and seperated by semicolon. Here is what I've been trying :

    Sub ConcatenateCellsToActiveCell_Semicolon()
    Dim rngCell As Range
    Dim rngActive As Range
    Dim strTemp As String
 
    Set rngActive = Selection
    strTemp = ""
 
    For Each rngCell In rngActive
        strTemp = strTemp & rngCell.Value
        strTemp = strTemp & "; "
        'rngCell.Value = ""  'Uncomment to clear selected, non-active cells
    Next
    ActiveCell.Value = Left(strTemp, Len(strTemp) - 2)
 
    Set rngActive = Nothing
End Sub

Here is the illustration what I want to achieve:

https://ibb.co/HzCr3JN << this is the begining
https://ibb.co/wSx2TwZ << this is the result that I want

And here is the result from the VBA that I tried https://ibb.co/DzCKCvf

Thaks for your help.

CodePudding user response：

Text Join in First Row

Adjust the values in the constants section.
After you select a range and run the sub, using the given delimiter, the values of each column are joined in the columns' first cell and the values in the other rows are optionally cleared.

Single Range Solution (Contiguous)

Sub JoinFirstInRow()
    
    Const Delimiter As String = " "
    Const ClearOtherRows As Boolean = True
    Const Title As String = "Join in First Row"
    
    Dim ash As Object: Set ash = ActiveSheet
    
    If ash Is Nothing Then Exit Sub ' no visible workbooks open
    If Not TypeOf ash Is Worksheet Then Exit Sub ' not a worksheet
    If Not TypeOf Selection Is Range Then Exit Sub ' not a range
    
    Dim rg As Range: Set rg = Selection
    
    Dim TextJoined As Boolean
    TextJoined = TextJoinInFirstRow(rg, Delimiter, ClearOtherRows, Title)
    
    If Not TextJoined Then Exit Sub
    
    'rg.EntireColumn.AutoFit
    
    MsgBox "Text joined in first row (" & rg.Rows(1).Address(0, 0) & ").", _
        vbInformation, Title

End Sub

Function TextJoinInFirstRow( _
    ByVal rg As Range, _
    Optional ByVal Delimiter As String = " ", _
    Optional ByVal ClearOtherRows As Boolean = True, _
    Optional ByVal Title As String = "Microsoft Excel") _
As Boolean
    
    With rg.Areas(1)
        
        Dim srCount As Long: srCount = .Rows.Count
        If srCount = 1 Then
            MsgBox "Cannot join one row.", vbExclamation, Title
            Exit Function
        End If
        
        Dim sData() As Variant: sData = .Value
        
        Dim drCount As Long: drCount = IIf(ClearOtherRows, srCount, 1)
        Dim cCount As Long: cCount = .Columns.Count
        
        Dim dData() As String: ReDim dData(1 To drCount, 1 To cCount)
        
        Dim sr As Long
        Dim c As Long
        Dim dr As Long
        Dim cString As String
        
        For c = 1 To cCount
            cString = CStr(sData(1, c))
            For sr = 2 To srCount
                cString = cString & Delimiter & CStr(sData(sr, c))
            Next sr
            dData(1, c) = cString
        Next c
    
        .Resize(drCount).Value = dData
        
    End With
        
    TextJoinInFirstRow = True
        
End Function

Multi-Range Solution (Non-Contiguous)

Sub JoinFirstInRow()
    
    Const Delimiter As String = " "
    Const ClearOtherRows As Boolean = True
    
    Dim ash As Object: Set ash = ActiveSheet
    
    If ash Is Nothing Then Exit Sub ' no visible workbooks open
    If Not TypeOf ash Is Worksheet Then Exit Sub ' not a worksheet
    If Not TypeOf Selection Is Range Then Exit Sub ' not a range
    
    Dim rg As Range: Set rg = Selection
    
    TextJoinInFirstRow rg, Delimiter, ClearOtherRows
    
End Sub

Sub TextJoinInFirstRow( _
        ByVal rg As Range, _
        Optional ByVal Delimiter As String = " ", _
        Optional ByVal ClearOtherRows As Boolean = True)
        
    Dim arg As Range
    Dim sData() As Variant
    Dim dData() As String
    
    Dim drCount As Long
    Dim cCount As Long
    
    Dim sr As Long
    Dim c As Long
    Dim dr As Long
    Dim dString As String
    
    For Each arg In rg.Areas
        
        Dim srCount As Long: srCount = arg.Rows.Count
        
        If srCount > 1 Then
            sData = arg.Value
            drCount = IIf(ClearOtherRows, srCount, 1)
            cCount = arg.Columns.Count
            ReDim dData(1 To drCount, 1 To cCount)
        
            For c = 1 To cCount
                dString = CStr(sData(1, c))
                For sr = 2 To srCount
                    dString = dString & Delimiter & CStr(sData(sr, c))
                Next sr
                dData(1, c) = dString
            Next c
        
            arg.Resize(drCount).Value = dData
        End If
        
    Next arg
        
End Sub