Concatenate Columns using VBA

[Japhet]

Hi Guys,

I need a code that will perform below requirements.

Excel VBA Concatenate Columns from A1 to AZ1 and so on.. then it will loop untill it reaches to last row e.g A10000 to B10000 and so on.. refer to below:
A1 = ABC
B1 = DEF
C1 = GHI
A2 = 123
B2 = 456
C2 = 789
result in the other sheets.
A1 = ABCDEFGHI
A2 = 123456789

Any help will be highly appreciated

Brgds,
Japhet

 

[dave3009]

Hi and welcome

try this

Sub CatS1toS2()
Dim lstRw As Long
Dim lstCl As Long
Dim i As Long
Dim j As Long
Dim result As Variant
lstRw = Sheet1.Range("A" & Rows.Count).End(xlUp).Row

For i = 1 To lstRw
    lstCl = Sheet1.Cells(i, Columns.Count).End(xlToLeft).Column
        For j = 1 To lstCl
            result = result & Sheet1.Cells(i, j)
        Next j
        Sheet2.Range("A" & i) = result
        result = ""
Next i

End Sub

 

[stnkynts]

Try:

Option Explicit
Sub CombineColumnstoColumn()
Dim icell As Long, lastrow As Long, lastcol As Long, iConc As Long
Dim myValue As String
 
lastrow = Range("A" & Rows.Count).End(xlUp).Row
 
Application.ScreenUpdating = False
For icell = 1 To lastrow
    lastcol = Cells(icell, Columns.Count).End(xlToLeft).Column
    myValue = Cells(icell, 1).Value
        For iConc = 2 To lastcol
            myValue = myValue & Cells(icell, iConc).Value
        Next iConc
    Range("A" & icell).Value = myValue
Next icell
Application.ScreenUpdating = True
End Sub

 

[mikerickson]

Put =ConcatIf(Sheet1!$1:$1, "<>", Sheet1!$1:$1, "") in Sheet2!a1

Function ConcatIf(ByVal compareRange As Range, ByVal xCriteria As Variant, Optional ByVal stringsRange As Range, _
                    Optional Delimiter As String, Optional NoDuplicates As Boolean) As String
                    
    Rem the first three argumens of ConcatIf mirror those of SUMIF
    Rem the Delimiter and NoDuplicates arguments are optional (default "" and False)
    Dim i As Long, j As Long
    
    With compareRange.Parent
        Set compareRange = Application.Intersect(compareRange, Range(.UsedRange, .Range("a1")))
    End With
    
    If compareRange Is Nothing Then Exit Function
    If stringsRange Is Nothing Then Set stringsRange = compareRange
    Set stringsRange = compareRange.Offset(stringsRange.Row - compareRange.Row, _
                                            stringsRange.Column - compareRange.Column)
    
    For i = 1 To compareRange.Rows.Count
        For j = 1 To compareRange.Columns.Count
            If (Application.CountIf(compareRange.Cells(i, j), xCriteria) = 1) Then
                If InStr(ConcatIf, Delimiter & CStr(stringsRange.Cells(i, j))) <> 0 Imp Not (NoDuplicates) Then
                    ConcatIf = ConcatIf & Delimiter & CStr(stringsRange.Cells(i, j))
                End If
            End If
        Next j
    Next i
    ConcatIf = Mid(ConcatIf, Len(Delimiter) + 1)
End Function

 

[Japhet]

Wow! thanks a lot guyz.. I think I will give the credits for dave now since he was the first one gives the solution and I'm currently using it right now. stnkynts and mikerikson and dave, you guyz are gem!

 

[melvinkoshy]

I have a similar problem,

I have two columns which I should be able to define in the function. If I enter ConcatIf(A1:A2,B1:B2) in a single cell, the output should be

ABC - DEF
123 - 456

Please help

 

[Rick Rothstein]

I have a similar problem,

I have two columns which I should be able to define in the function. If I enter ConcatIf(A1:A2,B1:B2) in a single cell, the output should be

ABC - DEF
123 - 456

Does this UDF (user defined function) do what you want (note that I changed the name of your function as the "If" part of it did not seem to apply)...

[table="width: 500"]
[tr]
	[td]Function ConcatAcross(Rng1 As Range, Rng2 As Range) As String
  Dim R As Long
  If Rng1.Rows.Count <> Rng2.Rows.Count Or Rng1.Columns.Count + Rng2.Columns.Count > 2 Then
    ConcatAcross = CVErr(xlErrRef)
  Else
    For R = 1 To Rng1.Rows.Count
      ConcatAcross = ConcatAcross & vbLf & Rng1(R).Value & " - " & Rng2(R).Value
    Next
  End If
End Function[/td]
[/tr]
[/table]

NOTE: You will have to turn "Wrap Text" on for the cell you put this function in in order to be able to see the multiple lines of text that it outputs.

 

[melvinkoshy]

How do we avoid records in which either member of the pair is blank

 

[Rick Rothstein]

How do we avoid records in which either member of the pair is blank

I assume you mean don't do anything if either (or both) are blank. See if this works for you...

[table="width: 500"]
[tr]
	[td]Function ConcatAcross(Rng1 As Range, Rng2 As Range) As String
  Dim R As Long
  If Rng1.Rows.Count <> Rng2.Rows.Count Or Rng1.Columns.Count + Rng2.Columns.Count > 2 Then
    ConcatAcross = CVErr(xlErrRef)
  Else
    For R = 1 To Rng1.Rows.Count
      If Len(Rng1(R).Value) > 0 And Len(Rng2(R).Value) > 0 Then ConcatAcross = ConcatAcross & vbLf & Rng1(R).Value & " - " & Rng2(R).Value
    Next
  End If
End Function[/td]
[/tr]
[/table]

 

[melvinkoshy]

The code works perfectly for me. But there is a vertical space which is seen above the output cell. I have set the vertical alignment to “top” but still the space is seen.

https://i.imgur.com/zLcpytl.jpg

Can the cell height and alignment be automatically adjusted where the =ConcatAcross function is entered