Merge Same Column Name

[christian2016]

Hi Guys,

Need help on how to merge same column names with data.

Example
City | State | Address | Address | Address

Now I would like to loop through the column headers and if finds the same column header name in this example would be address it will combined all the text information in all columns with spaces in-between.
All information will be stored in one column called address and the other 2 address columns will be deleted.

Unsure on how to approach this to make something dynamic.

Any help is greatly appreciated.

Thanks

 

[bebo021999]

Like this?

Sub test()
Dim Arr() As Variant
Lr = Range("A2").CurrentRegion.Rows.Count
Lc = Range("A2").CurrentRegion.Columns.Count
ReDim Arr(Lr - 1)
firstAdd = Range(Cells(1, 1), Cells(1, Lc)).Find("Address").Offset(0, 1).Address
LastAdd = Range(Cells(1, 1), Cells(1, Lc)).Find("Address", , , , xlByRows, xlPrevious).Address
For i = 2 To Lr
  For j = 1 To Lc
    If Cells(1, j).Value = "Address" Then
       combi = combi & Cells(i, j) & " "
    End If
  Next
Arr(i - 2) = Trim(combi)
combi = ""
Next
    With Range(firstAdd)
    For t = 0 To UBound(Arr)
    .Offset(t + 1, -1) = Arr(t)
    Next
    Range(firstAdd, LastAdd).EntireColumn.Delete
    Cells.Columns.AutoFit
    Range("A1").Select
    End With
End Sub

 

[Peter_SSs]

I would like to loop through the column headers and if finds the same column header name

This will look for any repeat header names, not just 'Address'. Test with a copy of your worksheet.
I have assumed that column A can be used to locate the bottom of the data.

Sub Combine_Columns()
  Dim c As Long, j As Long, lr As Long, cc As Long
  Dim Hdr As String
  
  lr = Range("A" & Rows.Count).End(xlUp).Row
  Application.ScreenUpdating = False
  For c = Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
    If Not IsEmpty(Cells(1, c).Value) Then
      Hdr = Cells(1, c).Value
      cc = c
      For j = c - 1 To 1 Step -1
        If Cells(1, j).Value = Hdr Then
          With Cells(2, j).Resize(lr - 1)
            .Value = Evaluate("trim(" & .Address & "&"" ""&" & .Offset(, cc - j).Address & ")")
          End With
          Columns(cc).Delete
          cc = j
        End If
      Next j
    End If
  Next c
  ActiveSheet.UsedRange.Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

Before

christian2016.xlsm
	A	B	C	D	E	F
1	City	State	Address	State	Address	Address
2	City 12	State 2	Address 11	State 6		Address 3
3	City 9	State 17	Address 9
4	City 6	State 1	Address 99
5	City 15			State 11	Address 19	Address 8
6	City 16	State 6	Address 5	State 6	Address 8	Address 16
7	City 7	State 19	Address 19	State 7		Address 15
8	City 19	State 3	Address 2	State 1	Address 12	Address 1
9	City 1	State 5	Address 7
Sheet1

After

christian2016.xlsm
	A	B	C
1	City	State	Address
2	City 12	State 2 State 6	Address 11 Address 3
3	City 9	State 17	Address 9
4	City 6	State 1	Address 99
5	City 15	State 11	Address 19 Address 8
6	City 16	State 6 State 6	Address 5 Address 8 Address 16
7	City 7	State 19 State 7	Address 19 Address 15
8	City 19	State 3 State 1	Address 2 Address 12 Address 1
9	City 1	State 5	Address 7
Sheet1

 

[christian2016]

This will look for any repeat header names, not just 'Address'. Test with a copy of your worksheet.
I have assumed that column A can be used to locate the bottom of the data.

Sub Combine_Columns()
  Dim c As Long, j As Long, lr As Long, cc As Long
  Dim Hdr As String
 
  lr = Range("A" & Rows.Count).End(xlUp).Row
  Application.ScreenUpdating = False
  For c = Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
    If Not IsEmpty(Cells(1, c).Value) Then
      Hdr = Cells(1, c).Value
      cc = c
      For j = c - 1 To 1 Step -1
        If Cells(1, j).Value = Hdr Then
          With Cells(2, j).Resize(lr - 1)
            .Value = Evaluate("trim(" & .Address & "&"" ""&" & .Offset(, cc - j).Address & ")")
          End With
          Columns(cc).Delete
          cc = j
        End If
      Next j
    End If
  Next c
  ActiveSheet.UsedRange.Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

Before

christian2016.xlsm
	A	B	C	D	E	F
1	City	State	Address	State	Address	Address
2	City 12	State 2	Address 11	State 6		Address 3
3	City 9	State 17	Address 9
4	City 6	State 1	Address 99
5	City 15			State 11	Address 19	Address 8
6	City 16	State 6	Address 5	State 6	Address 8	Address 16
7	City 7	State 19	Address 19	State 7		Address 15
8	City 19	State 3	Address 2	State 1	Address 12	Address 1
9	City 1	State 5	Address 7
Sheet1

After

christian2016.xlsm
	A	B	C
1	City	State	Address
2	City 12	State 2 State 6	Address 11 Address 3
3	City 9	State 17	Address 9
4	City 6	State 1	Address 99
5	City 15	State 11	Address 19 Address 8
6	City 16	State 6 State 6	Address 5 Address 8 Address 16
7	City 7	State 19 State 7	Address 19 Address 15
8	City 19	State 3 State 1	Address 2 Address 12 Address 1
9	City 1	State 5	Address 7
Sheet1

This is exactly what im after. I will give it a go and see how it works. Thanks again ?

 

[Peter_SSs]

You're welcome. Hope it works for you. ?

 

[christian2016]

You're welcome. Hope it works for you. ?

it works but for some odd reason it only works for the first row. For example it will combined the row text just for the first row and keep the same value for each row after that.

 

[Peter_SSs]

it works but for some odd reason it only works for the first row.

First thought is: Did you check my assumption?

I have assumed that column A can be used to locate the bottom of the data.

Try this instead

Sub Combine_Columns_v2()
  Dim c As Long, j As Long, lr As Long, cc As Long
  Dim Hdr As String
  
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Application.ScreenUpdating = False
  For c = Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
    If Not IsEmpty(Cells(1, c).Value) Then
      Hdr = Cells(1, c).Value
      cc = c
      For j = c - 1 To 1 Step -1
        If Cells(1, j).Value = Hdr Then
          With Cells(2, j).Resize(lr - 1)
            .Value = Evaluate("trim(" & .Address & "&"" ""&" & .Offset(, cc - j).Address & ")")
          End With
          Columns(cc).Delete
          cc = j
        End If
      Next j
    End If
  Next c
  ActiveSheet.UsedRange.Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

 

[christian2016]

First thought is: Did you check my assumption?


Try this instead

Sub Combine_Columns_v2()
  Dim c As Long, j As Long, lr As Long, cc As Long
  Dim Hdr As String
 
  lr = Cells.Find(What:="*", LookIn:=xlValues, SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
  Application.ScreenUpdating = False
  For c = Cells(1, Columns.Count).End(xlToLeft).Column To 2 Step -1
    If Not IsEmpty(Cells(1, c).Value) Then
      Hdr = Cells(1, c).Value
      cc = c
      For j = c - 1 To 1 Step -1
        If Cells(1, j).Value = Hdr Then
          With Cells(2, j).Resize(lr - 1)
            .Value = Evaluate("trim(" & .Address & "&"" ""&" & .Offset(, cc - j).Address & ")")
          End With
          Columns(cc).Delete
          cc = j
        End If
      Next j
    End If
  Next c
  ActiveSheet.UsedRange.Columns.AutoFit
  Application.ScreenUpdating = True
End Sub

Yes all my headers are in column A. That works well. Thank you so much

 

[Peter_SSs]

Glad that resolved the issue. Thanks for letting us know.

 

[christian2016]

Glad that resolved the issue. Thanks for letting us know.

Having another issue now. Didn't pick it up before maybe because I was using the same data set.

Example

Tried to go through the code to try and fix it. Haven't been successful