Combine multiple rows into one with VBA

[mklindquist0815]

I have a spreadsheet that has values that looks similar to below (but with multiple IDs)

ID	Class	Submit Date	Post Date	Start Date	Complete Date
1172739	ENG102	9/7/2015
1172739	ENG102		9/4/2015
1172739	ENG102				9/9/2015
1172739	ENG102			9/3/2015

<tbody>
</tbody>

Is there any possible way to create VBA to squish all the data together for each ID and Class into one row? So that the ending result would look like below?

ID	Class	Submit Date	Post Date	Start Date	Complete Date
1172739	ENG102	9/7/2015	9/4/2015	9/3/2015	9/9/2015

<tbody>
</tbody>

 

[Kamolga]

I have a spreadsheet that has values that looks similar to below (but with multiple IDs)

ID	Class	Submit Date	Post Date	Start Date	Complete Date
1172739	ENG102	9/7/2015
1172739	ENG102		9/4/2015
1172739	ENG102				9/9/2015
1172739	ENG102			9/3/2015

<tbody>
</tbody>

Is there any possible way to create VBA to squish all the data together for each ID and Class into one row? So that the ending result would look like below?

ID	Class	Submit Date	Post Date	Start Date	Complete Date
1172739	ENG102	9/7/2015	9/4/2015	9/3/2015	9/9/2015

<tbody>
</tbody>

Hi,

You can do it with a pivot table (press record macro if you want vba code): put ID and class in rows and in sum segment, simply put sum of each date...then reformat the cells as dates, take off (sub)totals and maybe use tabular layout.

 

[Kamolga]

If ID is in A1 then the code below should work

[COLOR=#008000]'Dim 2 search cells[/COLOR]
Dim BlankCell As Range
Dim IdCell As Range

[COLOR=#008000]
'Find Last row and column[/COLOR]

Dim lRow As Long
lRow = Range("A1").End(xlDown).Row
Dim lColumn As Long
lColumn = Range("A1").End(xlToRight).Column

[COLOR=#008000]'Set the area to consider[/COLOR]

Dim Rng As Range
Set Rng = Range(Cells(1, 1), Cells(lRow, lColumn))

[COLOR=#008000] 'Select​ each blank cell in area[/COLOR]

    Rng.Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    
 [COLOR=#008000]'And replace it with appropriate value[/COLOR]
    For Each BlankCell In Selection
             For Each IdCell In Range(Cells(1, 1), Cells(lRow, 1))
                      If (IdCell.Value = Cells(BlankCell.Row, 1).Value And Cells(IdCell.Row, BlankCell.Column) <> "") Then
                        BlankCell = Cells(IdCell.Row, BlankCell.Column).Value
                      End If
             Next IdCell
    Next BlankCell

[COLOR=#008000] 'Then​ erase duplicate lines[/COLOR]
    Rng.Select
    ActiveSheet.Range(Cells(1, 1), Cells(lRow, lColumn)).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6), _
        Header:=xlYes

 

[Gingertrees]

Quite brilliant, Kamolga! I've been very curious how this one would be solved.

mklindquist0815 :
I would turn off screenupdating before running the above code, FYI:

Sub SquishLines
Application.ScreenUpdating = False
'//Kamolga's code here//

Application.ScreenUpdating = True
End Sub

 

[mklindquist0815]

Pivot table sounds great except there are more fields in the table than just the class and ID and the other columns. I can see how it looks though.

 

[Gingertrees]

I'm guessing you're a little leery of the VBA code? It's actually the faster/simpler method. I'll take you through it step by step.
***NOTE: Make sure you make a copy of your spreadsheet beforehand, in case you want the original (Right click, Move or copy, check "Create a copy")***
Insert code
1) Can you see the Developer tab in the Excel ribbon? If not, click on File | Options | Customize Ribbon, then check Developer and click OK.
2) Click on the Developer tab. Click "Visual Basic"
3) In the Visual Basic window, Insert menu, "Module"
4) Copy all of the code below:

Sub compressit()
'//This code is set up to turn
'//ID   Name    Mo    Day   Year
'//ID1  Joe                 1980
'//ID1  Joe     May
'//ID1  Joe           10
'////////////////INTO//////////
'//ID1  Joe     May   10    1980
'//////////////////////////////

Application.ScreenUpdating = False
'//////below code created by user Kamolga!//////
Dim BlankCell As Range
Dim IdCell As Range

'Find Last row and column
Dim lRow As Long
lRow = Range("A1").End(xlDown).Row
Dim lColumn As Long
lColumn = Range("A1").End(xlToRight).Column
'Set the area to consider

Dim Rng As Range
Set Rng = Range(Cells(1, 1), Cells(lRow, lColumn))
 'Select? each blank cell in area

    Rng.Select
    Selection.SpecialCells(xlCellTypeBlanks).Select
    
 'And replace it with appropriate value
    For Each BlankCell In Selection
             For Each IdCell In Range(Cells(1, 1), Cells(lRow, 1))
                      If (IdCell.Value = Cells(BlankCell.Row, 1).Value And _
                        Cells(IdCell.Row, BlankCell.Column) <> "") Then
                        BlankCell = Cells(IdCell.Row, BlankCell.Column).Value
                      End If
             Next IdCell
    Next BlankCell

 'Then? erase duplicate lines
    Rng.Select
    ActiveSheet.Range(Cells(1, 1), Cells(lRow, lColumn)).RemoveDuplicates _
        Columns:=Array(1, 2, 3, 4, 5, 6), Header:=xlYes
Range("A1").Select
Application.ScreenUpdating = True
End Sub

5) Paste it into your newly-inserted module.
6) Look at your spreadsheet again. In the Developer tab, click "Macros". Select CompressIt and choose "Run".

 

[Kamolga]

Pivot table sounds great except there are more fields in the table than just the class and ID and the other columns. I can see how it looks though.

Please note that the remove duplicate part (last in the code) is based on 6 first columns.

[COLOR=#008000]'Then​ erase duplicate lines
[/COLOR]    Rng.Select
    ActiveSheet.Range(Cells(1, 1), Cells(lRow, lColumn)).RemoveDuplicates Columns:=Array([COLOR=#ff0000]1, 2, 3, 4, 5, 6[/COLOR]), _
        Header:=xlYes

In addition the code is filling all blank cells for all columns: it look for a cell that has same ID and where the value in same column is not empty. It inserts this value and goes to the next empty cell.

 

[Kamolga]

Quite brilliant, Kamolga! I've been very curious how this one would be solved.

mklindquist0815 :
I would turn off screenupdating before running the above code, FYI:

Sub SquishLines
Application.ScreenUpdating = False
'//Kamolga's code here//

Application.ScreenUpdating = True
End Sub

Thank you

I always forget the screedupdating when I work with small amount of data...and indeed in this case it will optimize speed and look much Professional.

 

[Gingertrees]

the remove duplicate part (last in the code) is based on 6 first columns.

So if (for example) the code had 10 columns set up in a similar way, could the array just be expanded to fit that?

Edit: code viewer keeps acting weird here, but I'm trying to say, would the Array(1, 2, 3, 4, 5, 6) just need to be tweaked to
Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ?

 

[Kamolga]

So if (for example) the code had 10 columns set up in a similar way, could the array just be expanded to fit that?

Edit: code viewer keeps acting weird here, but I'm trying to say, would the Array(1, 2, 3, 4, 5, 6) just need to be tweaked to
Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10) ?

Yes