Excel 2007 : Combine Multiple rows in Excel

[Czkeit]

I have a list of about 4,000 contacts each with about 2 or 3 products with us. Each product creates a new contact row.

I would like to merge each row with the same contact into one row. I have attached an example
Thank you so much for your help

[tigeravatar]

Czkeit,

Welcome to the forum!

Give the below macro a try.

How to use a macro:

1. Make a copy of the workbook the macro will be run on
   • Always run new code on a workbook copy, just in case the code doesn't run smoothly
   • This is especially true of any code that deletes anything
2. In the copied workbook, press ALT+F11 to open the Visual Basic Editor
3. Insert | Module
4. Copy the provided code and paste into the module
5. Close the Visual Basic Editor
6. In Excel, press ALT+F8 to bring up the list of available macros to run
7. Double-click the desired macro (I named this one tgr)

Sub tgr()
    
    Dim arrUnq() As Variant
    Dim arrIndex As Long
    Dim ColIndex As Long
    Dim rngVis As Range
    Dim rngVal As Range
    
    With Intersect(ActiveSheet.UsedRange, Columns("B"))
        .AdvancedFilter xlFilterCopy, , Cells(1, Columns.Count), True
        arrUnq = Application.Transpose(Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Value)
        Columns(Columns.Count).Delete
        For arrIndex = LBound(arrUnq) To UBound(arrUnq)
            .AutoFilter 1, arrUnq(arrIndex)
            Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            For ColIndex = Columns("W").Column To Columns("AL").Column
                Set rngVal = Cells(1, ColIndex).End(xlDown)
                If rngVal.Row <> Rows.Count Then Cells(rngVis.Row, ColIndex).Value = rngVal.Value
            Next ColIndex
            rngVis.Offset(1).Delete xlShiftUp
        Next arrIndex
        .AutoFilter
    End With
    
End Sub

[bryanbak3]

Wow tiger that is really cool! There is no information lost in that?

[tigeravatar]

In the example workbook provided there was no information lost. Like I said though, macros should be run on a copy of the original workbook; then compare the results to the original to ensure that both nothing was lost and the macro performed as desired.

[Czkeit]

I dont know why but it is giving me an error when I try to run the macro the error says

"run-time error '1004':
no cells were found"

and then it gives me an option to "debug" but I dont know what that is.
I tested it on the example that I gave you that came from my origional list and it worked perfect on that

[tigeravatar]

Give this version a try:

Sub tgr()
    
    Dim arrUnq() As Variant
    Dim arrIndex As Long
    Dim ColIndex As Long
    Dim rngVis As Range
    Dim rngVal As Range
    Dim rngDel As Range
    
    On Error Resume Next
    With Intersect(ActiveSheet.UsedRange, Columns("B"))
        .AdvancedFilter xlFilterCopy, , Cells(1, Columns.Count), True
        arrUnq = Application.Transpose(Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Value)
        Columns(Columns.Count).Delete
        For arrIndex = LBound(arrUnq) To UBound(arrUnq)
            .AutoFilter 1, arrUnq(arrIndex)
            Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            If Not rngVis Is Nothing Then
                For ColIndex = Columns("W").Column To Columns("AL").Column
                    Set rngVal = Cells(1, ColIndex).End(xlDown)
                    If rngVal.Row <> Rows.Count Then Cells(rngVis.Row, ColIndex).Value = rngVal.Value
                Next ColIndex
                If rngDel Is Nothing Then
                    Set rngDel = rngVis.Offset(1)
                Else
                    Set rngDel = Union(rngDel, rngVis.Offset(1))
                End If
                Set rngVis = Nothing
            End If
        Next arrIndex
        .AutoFilter
        If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlShiftUp
    End With
    
End Sub

[Czkeit]

I’m not sure what that one did, I didn't get an error this time but it is not merging the rows that I need merged and it is deleting what seems to be random rows. Is there a way to make the macro merge the rows based on the column title: "custid". So if there are three rows with the custid as "4" those three rows would merge into one and delete the other two? I’m sorry this has been so complicated I truly appreciate your help

[tigeravatar]

Adjusted code, give this a try:

Sub tgr()
    
    Dim arrUnq() As Variant
    Dim arrIndex As Long
    Dim ColIndex As Long
    Dim rngVis As Range
    Dim rngVal As Range
    
    On Error Resume Next
    With Intersect(ActiveSheet.UsedRange, Columns("I"))
        .AdvancedFilter xlFilterCopy, , Cells(1, Columns.Count), True
        arrUnq = Application.Transpose(Range(Cells(2, Columns.Count), Cells(1, Columns.Count).End(xlDown)).Value)
        Columns(Columns.Count).Delete
        For arrIndex = LBound(arrUnq) To UBound(arrUnq)
            .AutoFilter 1, arrUnq(arrIndex)
            Set rngVis = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
            If Not rngVis Is Nothing Then
                For ColIndex = Columns("W").Column To Columns("AL").Column
                    Set rngVal = Cells(1, ColIndex).End(xlDown)
                    If rngVal.Row <> Rows.Count Then Cells(rngVis.Row, ColIndex).Value = rngVal.Value
                Next ColIndex
                rngVis.Offset(1).EntireRow.Delete xlShiftUp
                Set rngVis = Nothing
            End If
        Next arrIndex
        .AutoFilter
    End With
    
End Sub

[Czkeit]

This one seems to be merging some of the rows correctly, but not all only about a third of them and deleting other essential rows without merging first

[tigeravatar]

That code works on the example workbook. To correct issues I'd have to see where its going wrong

[Czkeit]

What do you need from me to do that?

[tigeravatar]

A new example workbook that contains data that the code doesn't run correctly on.

[Czkeit]

Im not sure what I did wrong last time but it is now working you have been so helpful thank you so much

[Czkeit]

Well I miss spoke It is only working about 50% of the time. It Merges several of the rows together but just deletes others without Merging. Is there a way I can privately share teh workbook with you?

[tigeravatar]

I would recommend scrubbing sensitive data and uploading a sample workbook containing data the macro doesn't run correctly on instead.

From the forum rules:
4. Don't Private Message or email questions to moderators or other members. The point of having a public forum is to share solutions to common (and sometimes uncommon) problems with all members

[Czkeit]

OK here is a scrubbed version of myScrubed Data.xlsx entire list.
Note that after the Macro is ran CustID #'s 13, 187, 2374, and 2872 have missing policies. These are just random ones that I pulled out. Most of the rows were merged properly I can’t see any pattern to these errors.

[eyecatchers]

This is brilliant
I have table that has the product data row after row and need to join row cells together
I have used the tool www.asap-utilities.com which is excellent but the process is manual
Can you assist ?

[tigeravatar]

Czkeit,

Updated code, verified it works for the lines specified, let me know if you find further bugs:

Sub tgr()
    
    Dim rngUR As Range
    Dim rngUnq As Range
    Dim arrData As Variant
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    Set rngUR = ActiveSheet.UsedRange
    Set rngUnq = Cells(1, Columns.Count - 17)
    Intersect(rngUR, Columns("I")).AdvancedFilter xlFilterCopy, , rngUnq, True
    Set rngUnq = Range(rngUnq.Offset(1), rngUnq.End(xlDown))
    
    With rngUnq.Offset(, 1).Resize(, 16)
        .Formula = "=IF(COUNTIFS($I$2:$I$" & rngUR.Rows.Count & "," & Cells(2, rngUnq.Column).Address(0, 1) & ",W$2:W$" & rngUR.Rows.Count & ",TRUE)>0,TRUE,"""")"
        arrData = .Value
        Range(Cells(1, rngUnq.Column), Cells(1, Columns.Count)).EntireColumn.Delete
    End With
    
    rngUR.RemoveDuplicates Columns("I").Column, xlYes
    Range("W2").Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

[Czkeit]

Everything is working great I dont see any other bugs. This is very cool I wish I knew how to write Macros. I have a question though, the data that I gave you to work with was based on a template where W through AL were the columns that needed to be merged. Sometimes the data that I get is different would the macro apply if it was W through AC or even V through AL? if not is there an easy way to change the macro?

[tigeravatar]

Czkeit,

I updated the macro so that it can be easily changed as needed:
CstIDCol is the column letter containing CustID's.
StartCol is the column letter that the macro should start looking at.
FinalCol is the column letter that the macro should stop looking at.

Change those three as needed, the macro will adjust as necessary.

Sub tgr()
    
    Const CstIDCol As String = "I"
    Const StartCol As String = "W"
    Const FinalCol As String = "AL"
    
    Dim NumCols As Long
    Dim rngUR As Range
    Dim rngUnq As Range
    Dim arrData As Variant
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .Calculation = xlCalculationManual
    End With
    
    NumCols = Cells(1, FinalCol).Column - Cells(1, StartCol).Column + 1
    
    Set rngUR = ActiveSheet.UsedRange
    Set rngUnq = Cells(1, Columns.Count - NumCols - 1)
    Intersect(rngUR, Columns(CstIDCol)).AdvancedFilter xlFilterCopy, , rngUnq, True
    Set rngUnq = Range(rngUnq.Offset(1), rngUnq.End(xlDown))
    
    With rngUnq.Offset(, 1).Resize(, NumCols)
        .Formula = "=IF(COUNTIFS($" & CstIDCol & "$2:$" & CstIDCol & "$" & rngUR.Rows.Count & "," & Cells(2, rngUnq.Column).Address(0, 1) & "," & StartCol & "$2:" & StartCol & "$" & rngUR.Rows.Count & ",TRUE)>0,TRUE,"""")"
        arrData = .Value
        Range(Cells(1, rngUnq.Column), Cells(1, Columns.Count)).EntireColumn.Delete
    End With
    
    rngUR.RemoveDuplicates Columns(CstIDCol).Column, xlYes
    Cells(2, StartCol).Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    
    With Application
        .Calculation = xlCalculationAutomatic
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    
End Sub

[Czkeit]

I have another thing that I would like to do to the data (the last thing) but im not sure if it is something that sould be added to this macro or a different one entirely when I get the data it looks like this:

All of the policies are in one column, then I mannually seperate them into there own columns, auto , home, DF ect. Then change each cell to say "True" is this something a macro could automate and could it be done with the same macro you gave me?

[tigeravatar]

Czkeit,

Updated code to include request. Give it a try:

Sub tgr()
    
    Const CustIDCol As String = "I"
    Const PolicyCol As String = "X"
    
    Dim LastRow As Long
    Dim rngIDs As Range
    Dim rngPol As Range
    Dim arrData As Variant
    Dim CritRng1 As String, Crit1 As String
    Dim CritRng2 As String, Crit2 As String
    
    'Allows for faster code running
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    
    'Get last row
    LastRow = Cells(Rows.Count, CustIDCol).End(xlUp).Row
    
    'Get unique list of policies for column headers
    Set rngPol = Cells(1, PolicyCol).Offset(, 1)
    Range(Cells(1, PolicyCol), Cells(LastRow, PolicyCol)).AdvancedFilter xlFilterCopy, , rngPol, True
    Set rngPol = Range(rngPol.Offset(1), rngPol.End(xlDown))
    Cells(1, Columns.Count - rngPol.Rows.Count + 1).Resize(, rngPol.Rows.Count).Value = Application.Transpose(rngPol.Value)
    
    'Get unique list of CustIDs
    Set rngIDs = Cells(1, Columns.Count - rngPol.Rows.Count)
    Range(Cells(1, CustIDCol), Cells(LastRow, CustIDCol)).AdvancedFilter xlFilterCopy, , rngIDs, True
    
    'Generate CountIfs formula arguments
    CritRng1 = "$" & CustIDCol & "$2:$" & CustIDCol & "$" & LastRow
    Crit1 = Cells(2, rngIDs.Column).Address(0, 1)
    CritRng2 = "$" & PolicyCol & "$2:$" & PolicyCol & "$" & LastRow
    Crit2 = Cells(1, rngIDs.Column + 1).Address(1, 0)
    
    'Use formula to get data results
    With Range(rngIDs.Offset(1), rngIDs.End(xlDown)).Offset(, 1).Resize(, rngPol.Rows.Count)
        .Formula = "=IF(COUNTIFS(" & CritRng1 & "," & Crit1 & "," & CritRng2 & "," & Crit2 & ")>0,TRUE,"""")"
    End With
    
    'Collect data results
    arrData = Range(rngIDs.Offset(, 1), Cells(1, Columns.Count).End(xlDown)).Value
    
    'Clean sheet and remove duplicates from actual data
    Range(Cells(1, PolicyCol), Cells(1, Columns.Count)).EntireColumn.Delete
    ActiveSheet.UsedRange.RemoveDuplicates Columns(CustIDCol).Column
    
    'Populate results
    Cells(1, PolicyCol).Resize(UBound(arrData, 1), UBound(arrData, 2)).Value = arrData
    
    'Turn screenupdating and calculation back on
    With Application
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
    
End Sub

[rosierat]

Hi
Like the previous enquirer, I am at a loss when it comes to writing macros, but I too have a worksheet (portion attached) where I would like to combine the rows where the number in the first column is duplicated - for example customer 288 would have one row, with entries in the input, output, static and offset columns.
Can you help?

[arlu1201]

rosierat,

Welcome to the Forum.

Unfortunately your post does not comply with Rule 2 of our Forum RULES. Do not post a question in the thread of another member -- start your own thread.

If you feel an existing thread is particularly relevant to your need, provide a link to the other thread in your new thread.

Old threads are often only monitored by the original participants. New threads not only open you up to all possible participants again, they typically get faster response, too.

[rosierat]

rosierat,

Welcome to the Forum.

Unfortunately your post does not comply with Rule 2 of our Forum RULES. Do not post a question in the thread of another member -- start your own thread.

If you feel an existing thread is particularly relevant to your need, provide a link to the other thread in your new thread.

Old threads are often only monitored by the original participants. New threads not only open you up to all possible participants again, they typically get faster response, too.

Sorry, I had not picked that up. I will repost

[arlu1201]

eyecatchers,

Please check post 23.