Multiple columns to one separeted by comas-CodePudding

I have files with 2k rows with data as below:

I want to change it to rows with one column where data is separeted with comas.

I found vba code which does the job but I have to select each row with columns separately, and it shows blank cells as bunch of comas which I won't to be shown.

My code:

Sub Columns_to_rows()
'
' Columns to rows Makro
'
Dim rng As Range
Dim InputRng As Range, OutRng As Range
Set InputRng = Application.Selection
Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
outStr = ""
For Each rng In InputRng
    If outStr = "" Then
        outStr = rng.Value
    Else
        outStr = outStr & "," & rng.Value
    End If
Next
OutRng.Value = outStr
End Sub

CodePudding user response：

As you have TEXTJOIN you can use this formula instead of VBA:

=BYROW(A1:G3,LAMBDA(r,TEXTJOIN(",",TRUE,r)))

Where you have to pass the region for which you want the joined values.

If you want to stay with a VBA solution, you can use this function:

Sub mergeColumnsToOneRowEach(rgStart As Range, rgTarget As Range)

Dim rgSource As Range
Set rgSource = rgStart.CurrentRegion

Dim arrSource As Variant
arrSource = rgSource.Value

Dim arrTarget As Variant
ReDim arrTarget(1 To UBound(arrSource, 1))

Dim i As Long, j As Long
For i = 1 To UBound(arrSource, 1)
    For j = 1 To UBound(arrSource, 2)
        If LenB(arrSource(i, j)) > 0 Then
            arrTarget(i) = arrTarget(i) & arrSource(i, j) & ", "
        End If
    Next
Next

'add apstroph to the start, so that text is inserted
'remove comma at the end
For i = 1 To UBound(arrTarget)
    arrTarget(i) = "'" & Left(arrTarget(i), Len(arrTarget(i)) - 2)
Next
        
rgTarget.Resize(UBound(arrTarget, 1), 1).Value = Application.Transpose(arrTarget)

End Sub

You have to pass the first cell of the area that should be treated plus the target cell where to place the new content.

I am using arrays to iterate - that's much faster then looking into the cells values.

CodePudding user response：

Using your existing code as a starting point, you could use the TEXTJOIN function formula to build your reply and then remove the formula leaving just the response:

Sub Columns_to_rows()
    '
    ' Columns to rows Macro
    '
    Dim rng As Range, ofst As Long
    Dim InputRng As Range, OutRng As Range
    Set InputRng = Application.Selection
    Set InputRng = Application.InputBox("Range :", xTitleId, InputRng.Address, Type:=8)
    Set OutRng = Application.InputBox("Out put to (single cell):", xTitleId, Type:=8)
    
    ofst = 0
    
    For Each rng In InputRng.Rows
        OutRng.Offset(ofst).Formula = "=TextJoin("","", True, " & rng.Address & ")"
        ofst = ofst   1
    Next
    OutRng.Resize(ofst).Value = OutRng.Resize(ofst).Value
    
End Sub

CodePudding user response：

A little different solution to Ike's. Simply select the range you want to merge and run the macro. The original data will be cleared and replaced by the merged values in the leftmost column.

Sub mergeCols()
    Dim separator As String
    separator = ","
    
    Dim arr() As Variant
    arr = Selection
    Selection.Clear
    For i = 1 To UBound(arr)
        Dim rowString As String
        rowString = vbNullString
        For j = 1 To UBound(arr, 2)
            Dim cellVal As String
            cellVal = arr(i, j)
            If Not cellVal = vbnullsting Then rowString = rowString & cellVal & separator
            arr(i, j) = vbNullString
        Next j
        Debug.Print rowString
        If Not rowString = vbNullString Then arr(i, 1) = Left(rowString, Len(rowString) - 1)
    Next i
    Selection = arr
End Sub