使用现有代码作为起点，可以使用TEXTJOIN函数公式构建回复，然后删除公式，只留下响应：

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

由于您有TEXTJOIN，因此可以使用以下公式代替VBA：
=BYROW(A1:G3,LAMBDA(r,TEXTJOIN(",",TRUE,r)))
必须传递要为其输入连接值的区域的位置。
如果要继续使用VBA解决方案，可以使用此函数：

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

您必须传递应该处理的区域的第一个单元格以及要放置新内容的目标单元格。
我使用数组来迭代--这比查看单元格值要快得多。

与Ike的解决方案稍有不同。只需选择要合并的范围并运行宏。原始数据将被清除，并被最左边列中的合并值所取代。

Sub mergeCols()
    Dim separator As String
    separator = ", "
    
    Dim arr() As Variant
    arr = Selection
    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 = vbNullString 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) - Len(separator))
    Next i
    Selection = arr
End Sub

因为我没有TEXTJOIN函数，我尝试如下：

Sub test()
Dim rg As Range: Dim col As Integer: Dim i As Integer
Set rg = ActiveSheet.UsedRange 'change if needed
col = Range(Split(rg.Address, ":")(1)).Column + 3
    For i = 1 To rg.Rows.Count
        Cells(i, col).Value = Join(Application.Transpose( _
        Application.Transpose(rg.Rows(i).SpecialCells(xlConstants))), ", ")
    Next i
End Sub

范围输入是活动工作表的使用范围。
结果将放在数据偏移量为（0，3）的最后一列。
该代码假定在一行数据中的中间没有空白单元格。
例如：
A1、B1、C1、D1---〉全部包含值---〉正确数据。
A1、C1、D1有数值，B1为空---〉数据不正确。