CODEWITHSUNDEEP
vbaexcel
MJ95
MJ95

Reputation: 479

Combine values in all rows when column header is the same

Another tricky problem. I have a cleaned data set with another macro, where I need to loop over the column headers and for each row, combine the values of the columns with the same header name in the first column, separated by ;

Sample data:

Test    Country     Test    Country 
123      456         789      012
abc      def         ghi      jkl
mno      pqr         stu      vwx

Desired output:

Test      Country
123;789   456;012
abc;ghi   def;jkl

I have tried something like this which definitely didn't work:

    Dim i As Long
i = 1
j = 1
Do Until Len(Cells(i, j).Value) = 0
    If Cells(i, j).Value = Cells(i, j + 1).Value Then
        Cells(i, j).Value = Cells(i, j).Value & ";" & Cells(i, j + 1).Value

        Rows(j + 1).Delete
    Else
        i = i + 1
        j = j + 1
    End If
Loop

Upvotes: 0

Views: 509

Answers (3)

user3598756
user3598756

Reputation: 29421

Try this (tested)

Option Explicit

Sub Main()
    Dim rng As Range, cell As Range, cell2 As Range, cell3 As Range, rngToDelete As Range
    Dim txt As String

    With Worksheets("myWorksheetName")
        With .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft))
            Set rngToDelete = .Offset(1).Resize(, 1)
            For Each cell In .Cells
                If Intersect(cell, rngToDelete) Is Nothing Then
                    Set rng = GetRange(cell, .Cells)
                    If Not rng Is Nothing Then
                        With Intersect(.Parent.UsedRange, cell.EntireColumn)
                        MsgBox .Offset(1).Resize(.Rows.Count - 1).SpecialCells(XlCellType.xlCellTypeConstants).Address                            
                            For Each cell2 In .Offset(1).Resize(.Rows.Count - 1).SpecialCells(XlCellType.xlCellTypeConstants)
                                txt = cell2.Value
                                For Each cell3 In rng
                                    txt = txt & ";" & .Parent.Cells(cell2.row, cell3.Column)
                                Next cell3
                                cell2.Value = txt
                            Next cell2
                        End With
                        Set rngToDelete = Union(rng, rngToDelete)
                    End If
                End If
            Next cell
            Intersect(.Cells, rngToDelete).EntireColumn.Delete
         End With
    End With
End Sub


Function GetRange(rngToSearchFor As Range, rngToSearchIn As Range) As Range
    Dim f As Range
    Dim firstAddress As String

    With rngToSearchIn
        Set f = .Find(What:=rngToSearchFor.Value, lookAt:=xlWhole, LookIn:=xlValues, After:=rngToSearchFor, SearchDirection:=xlNext)
        If Not f Is Nothing Then
           If f.Column > rngToSearchFor.Column Then
                firstAddress = f.Address
                Set GetRange = f
                Do
                   Set GetRange = Union(GetRange, f)
                   Set f = .FindNext(f)
                Loop While f.Column > rngToSearchFor.Column
            End If
        End If
    End With
End Function

Upvotes: 0

J Reid
J Reid

Reputation: 461

After a nice chat as agreed ... 

Sub ForLoopPair()

Dim lastRow As Integer: lastRow = Cells(xlCellTypeLastCell).Row     ' or w/e you had
Dim lastCol As Integer: lastCol = Cells(xlCellTypeLastCell).Column  ' or w/e you had

For DestCol = 1 To lastCol
   For ReadCol = DestCol + 1 To lastCol
      If Cells(1, DestCol) = Cells(1, ReadCol) Then
         For i = 2 To lastRow
            If Cells(i, ReadCol) <> "" Then
               Cells(i, DestCol) = Cells(i, DestCol) & ";" & Cells(i, ReadCol)
            End If
         Next i
      End If
   Next ReadCol
Next DestCol

For DestCol = 1 To lastCol
   If Cells(1, DestCol) = "" Then Exit For
   For ReadCol = lastCol To (DestCol + 1) Step -1
      If Cells(1, DestCol) = Cells(1, ReadCol) Then
         Columns(ReadCol).Delete
      End If
   Next
Next

End Sub

Upvotes: 1

J Reid
J Reid

Reputation: 461

Not sure what's different about the first answer but this one is tested in Excel 2010 with sample data provided

Sub B()

  Dim DestCol As Integer
  Dim ReadCol As Integer

  DestCol = 1
  ReadCol = 2

  While ActiveSheet.Cells(1, DestCol) <> ""
     If ActiveSheet.Cells(1, ReadCol) = ActiveSheet.Cells(1, DestCol) Then
        For i = 2 To ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row
           If ActiveSheet.Cells(i, ReadCol) <> "" Then
              ActiveSheet.Cells(i, DestCol) = ActiveSheet.Cells(i, DestCol) & ";" & ActiveSheet.Cells(i, ReadCol)
           End If
        Next i
        ActiveSheet.Columns(ReadCol).Delete
     ElseIf ActiveSheet.Cells(1, ReadCol + 1) <> "" Then
        ReadCol = ReadCol + 1
     Else
        ReadCol = DestCol + 2
        DestCol = DestCol + 1
     End If
  Wend

End Sub

Upvotes: 0

Related Questions