Excel macro: Combine rows if column match

Question

I want to be able to combine the rows for which the value in the first column matches, so that the values of non-blank cells are consolidated into one row. E.g.:

Mary Smith, A, [blank cell]

Mary Smith, [blank cell], B

-->

Mary Smith A B 

I've tried to use the code below:

Dim RowNum As Long, LastRow As Long

Application.ScreenUpdating = False

RowNum = 4

LastRow = Cells.SpecialCells(xlCellTypeLastCell).Row

Range("A4", Cells(LastRow, 13)).Select

For Each Row In Selection

 With Cells

If Cells(RowNum, 1) = Cells(RowNum + 1, 1) Then

 Cells(RowNum + 1, 1).Copy Destination:=Cells(RowNum, 1)

 Cells(RowNum + 1, 2).Copy Destination:=Cells(RowNum, 2)

 Cells(RowNum + 1, 3).Copy Destination:=Cells(RowNum, 3)

Cells(RowNum + 1, 4).Copy Destination:=Cells(RowNum, 4)

Cells(RowNum + 1, 5).Copy Destination:=Cells(RowNum, 5)

Cells(RowNum + 1, 6).Copy Destination:=Cells(RowNum, 6)

 Cells(RowNum + 1, 7).Copy Destination:=Cells(RowNum, 7)

 Cells(RowNum + 1, 8).Copy Destination:=Cells(RowNum, 8)

 Cells(RowNum + 1, 9).Copy Destination:=Cells(RowNum, 9)

 Cells(RowNum + 1, 10).Copy Destination:=Cells(RowNum, 10)

Cells(RowNum + 1, 11).Copy Destination:=Cells(RowNum, 11)

 Cells(RowNum + 1, 12).Copy Destination:=Cells(RowNum, 12)

 Cells(RowNum + 1, 13).Copy Destination:=Cells(RowNum, 13)

Rows(RowNum + 1).EntireRow.Delete

End If

End With

RowNum = RowNum + 1

Next Row

Application.ScreenUpdating = True

'

End Sub

This does a fine job of consolidating the data so that there are only unique values in the first column, HOWEVER, when the row is copied up, the values of blank cells copy over populated cells, which NOT what I want. So for instance, running this macro on the above data would yield:

Mary Smith, A, [blank cell]

Mary Smith, [blank cell], B

-->

Mary Smith, A, [blank cell]

Any insight into how I might modify the above code (or use something more elegant) would be appreciated!!

Answer 1

Here is another approach. Create a Personnel object. Each Personnel object can have multiple attributes (the non blank column entries in your original table).

By using the Key property of the collection object, and using the Name (column1 data) as the key, we can detect duplicates without having to sort the original data. And the number of attributes for each name is limited only by the size of the worksheet.

Other information is in the comments.

Insert a class object and rename it cPersonnel

Below is the code for the Class and Regular modules

Class Module

Option Explicit
Private pName As String
Private pAttrib As String
Private pAttribs As Collection

Public Property Get Name() As String
    Name = pName
End Property
Public Property Let Name(Value As String)
    pName = Value
End Property

Public Property Get Attrib() As String
    Attrib = pAttrib
End Property
Public Property Let Attrib(Value As String)
    pAttrib = Value
End Property

Public Property Get AttribS() As Collection
    Set AttribS = pAttribs
End Property
Public Function ADDAttribS(Value As String)
    pAttribs.Add Value
End Function

Private Sub Class_Initialize()
    Set pAttribs = New Collection
End Sub

Regular Module

Option Explicit
Sub PersonnelAttribs()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim cP As cPersonnel, colP As Collection
    Dim LastRow As Long, LastCol As Long
    Dim I As Long, J As Long

'Set source and results worksheets, ranges
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc.Cells
    LastRow = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
        searchorder:=xlByRows, searchdirection:=xlPrevious).Row
    LastCol = .Find(what:="*", after:=.Cells(1, 1), LookIn:=xlFormulas, _
        searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
End With

'Read source data into array
With wsSrc
    vSrc = Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With

'create and collect the Personnel objects
'Source data does not need to be sorted
Set colP = New Collection
On Error Resume Next
For I = 1 To UBound(vSrc, 1)
    If Trim(vSrc(I, 1)) <> "" Then
        Set cP = New cPersonnel
        With cP
            .Name = vSrc(I, 1)
            For J = 2 To UBound(vSrc, 2)
                If Trim(vSrc(I, J)) <> "" Then
                    .Attrib = Trim(vSrc(I, J))
                    .ADDAttribS .Attrib
                End If
            Next J
            colP.Add cP, .Name
            Select Case Err.Number
                Case 457 'duplicate name
                    Err.Clear
                    For J = 1 To .AttribS.Count
                        colP(.Name).ADDAttribS .AttribS(J)
                    Next J
                Case Is <> 0
                    Debug.Print Err.Number, Err.Description
                    Stop
            End Select
        End With
    End If
Next I
On Error GoTo 0

'Create results array
'Number of columns
For I = 1 To colP.Count
With colP(I)
    J = IIf(J > .AttribS.Count, J, .AttribS.Count)
End With
Next I

ReDim vRes(0 To colP.Count, 0 To J)

'Headers
vRes(0, 0) = "Name"
For J = 1 To UBound(vRes, 2)
    vRes(0, J) = "Attrib " & J
Next J

'Populate data
For I = 1 To colP.Count
With colP(I)
    vRes(I, 0) = .Name
    For J = 1 To .AttribS.Count
        vRes(I, J) = .AttribS(J)
    Next J
End With
Next I

'Clear old data and write new
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2) + 1)
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With .Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With
    .EntireColumn.AutoFit
End With   
End Sub

Original Data

Results after Macro

Answer 2

This will do it very quickly:

Sub foo()
    Dim ws As Worksheet
    Dim lstrow As Long

    Set ws = Sheets("Sheet1") ' Change to your sheet

    With ws
        lstrow = .Range("A" & .Rows.Count).End(xlUp).Row
        With .Range("B4:M" & lstrow)
            .Offset(, 26).FormulaR1C1 = "=IFERROR(INDEX(R4C[-26]:R" & lstrow & "C[-26],MATCH(1,INDEX((R4C1:R" & lstrow & "C1 = RC1)*(R4C[-26]:R" & lstrow & "C[-26] <>""""),),0)),"""")"
            ws.Calculate
            .Value = .Offset(, 26).Value
            .Offset(, 26).ClearContents
        End With
        With .Range("A4:M" & lstrow)
            .Value = .Value
            .RemoveDuplicates 1, xlGuess
        End With
    End With

End Sub

It basically uses the formula: =INDEX(B$4:B$4,MATCH(1,INDEX(($A$4:$A$4 = $A4)*(B$4:B$4 <>""),),0)) To find all the values. Puts those formulas in blank columns and then copies the data back and removes the duplicates.

This will do all 13 columns at once.

It also does not care how many times the value in Column A is repeated. There could be 4 Mary Smiths in that column. It will grab the first value in each column and use that.

Before:

After:

Answer 3

Try the below code

Sub test()
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For i = 4 To LastRow
        If ((Range("A" & i).Value = Range("A" & i + 1).Value) And (Range("B" & i).Value <> Range("B" & i + 1).Value) And ((Range("B" & i).Value = "") Or (Range("B" & i + 1).Value = "")) And (Range("C" & i).Value <> Range("C" & i + 1).Value) And ((Range("C" & i).Value = "") Or (Range("C" & i + 1).Value = ""))) Then
            If Range("B" & i).Value = "" Then
                Range("B" & i).Value = Range("B" & i + 1).Value
            ElseIf Range("B" & i + 1).Value = "" Then
                Range("B" & i + 1).Value = Range("B" & i).Value
            End If
            If Range("C" & i).Value = "" Then
                Range("C" & i).Value = Range("C" & i + 1).Value
            ElseIf Range("C" & i + 1).Value = "" Then
                Range("C" & i + 1).Value = Range("C" & i).Value
            End If
        End If
        Range("B" & i).EntireRow.Delete Shift:=(xlUp)
        LastRow = LastRow - 1
    Next i
End Sub