Consolidate Group Into a Single Line

  • Thread starter Thread starter Ricky Pang
  • Start date Start date
R

Ricky Pang

Hello Experts,
I had to repost this question as my original Sept 24th's posting crashed
along with everyone else's postings.

How do you, in code, group according to similar names, then consolidate
all of the row's "X"'s into a single line? Such as;
1) Group each similar name within Column A;
2) Start with the last line within that group;
3) Copy and Paste Special, Skip Blanks, onto the next row up
4) Then, go back down to the last row within the group;
5) Delete last row within the group
6) Loop; until all multiple names become just one row per name.

To Illustrate:
[Column]
A B C D E
Bill X X
Bill X X X
Bill X X
Sue X
Sue X
Bob X X
Bob X X

Should become:
A B C D E
Bill X X X X X
Sue X X
Bob X X X X


Thanks in advance,
Ricky
 
Are these really X's?

If yes, then this might work ok:

Option Explicit
Sub testme()

Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long

Dim FirstCol As Long
Dim iCol As Long

Set wks = Worksheets("sheet1")

With wks
FirstRow = 2 'header row?
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2 'names in column A

For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
For iCol = FirstCol To _
.Cells(iRow, .Columns.Count).End(xlToLeft).Column
If IsEmpty(.Cells(iRow, iCol)) Then
'do nothing
Else
'just move it up and overwrite anything there?
.Cells(iRow - 1, iCol).Value = .Cells(iRow, iCol).Value
End If
Next iCol
'delete this row with the same name
.Rows(iRow).Delete
End If
Next iRow
End With

End Sub

It keeps the value in the bottom row during the comparison.

Ricky said:
Hello Experts,
I had to repost this question as my original Sept 24th's posting crashed
along with everyone else's postings.

How do you, in code, group according to similar names, then consolidate
all of the row's "X"'s into a single line? Such as;
1) Group each similar name within Column A;
2) Start with the last line within that group;
3) Copy and Paste Special, Skip Blanks, onto the next row up
4) Then, go back down to the last row within the group;
5) Delete last row within the group
6) Loop; until all multiple names become just one row per name.

To Illustrate:
[Column]
A B C D E
Bill X X
Bill X X X
Bill X X
Sue X
Sue X
Bob X X
Bob X X

Should become:
A B C D E
Bill X X X X X
Sue X X
Bob X X X X

Thanks in advance,
Ricky
Click to expand...
 
Hi Dave,
I appreciate your response. The data in the cells would be either "X"s
or "1"s. After running your macro, I've elected to go with the "1"s
instead.

On your post:
With wks
FirstRow = 2 'header row? [Yes]
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2 'names in column A
Question:
As the search criteria is based on Column A's names, should it have been
{First Col = 1}?

Another part:
'just move it up and overwrite anything there?
.Cells(iRow - 1, iCol).Value = .Cells(iRow, iCol).Value
Question:
No, not overwriting the X's that is already on the previous row. I
wanted to paste special, skip blanks, so that the data is not
overwritten. The X's will just keep adding up a row until all of the
X's (or 1's), all amalgamate onto the first row of the groupings.

So far, your code does delete the multiple names, leaving only 1
distinct name each. But, I am having trouble working around the
consolidating all of the X's from multiple lines into just one line for
each group.

Thanks Dave for helping me.

Ricky
 
The easy stuff first. The iCol/FirstCol only refer to the columns that should
be checked & merged. Since the first column is the key column, you wouldn't
want: bob,bob,bob as the result.

The difficult part.

Your second question:
Do you mean you want the values strung together:
x,x,1,x,1

Then this might work:

Option Explicit
Sub testme2()

Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long

Dim FirstCol As Long
Dim iCol As Long

Set wks = Worksheets("sheet1")

With wks
FirstRow = 2 'header row?
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2 'names in column A

For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
For iCol = FirstCol To _
.Cells(iRow, .Columns.Count).End(xlToLeft).Column
If IsEmpty(.Cells(iRow, iCol)) Then
'do nothing
Else
If IsEmpty(.Cells(iRow - 1, iCol)) Then
.Cells(iRow - 1, iCol).Value _
= .Cells(iRow, iCol).Value
Else
.Cells(iRow - 1, iCol).Value _
= .Cells(iRow - 1, iCol).Value _
& " ," & .Cells(iRow, iCol).Value
End If
End If
Next iCol
'delete this row with the same name
.Rows(iRow).Delete
End If
Next iRow
End With

End Sub

or if the row above is not empty, then keep it and don't change it?
Then this might work:

Option Explicit
Sub testme3()

Dim wks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long

Dim FirstCol As Long
Dim iCol As Long

Set wks = Worksheets("sheet1")

With wks
FirstRow = 2 'header row?
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2 'names in column A

For iRow = LastRow To FirstRow + 1 Step -1
If .Cells(iRow, "A").Value = .Cells(iRow - 1, "A").Value Then
For iCol = FirstCol To _
.Cells(iRow, .Columns.Count).End(xlToLeft).Column
If IsEmpty(.Cells(iRow - 1, iCol)) = False Then
'do nothing
Else
'just move it up and overwrite anything there?
.Cells(iRow - 1, iCol).Value = .Cells(iRow, iCol).Value
End If
Next iCol
'delete this row with the same name
.Rows(iRow).Delete
End If
Next iRow
End With

End Sub

(Just check the cell above. If it's not empty, don't touch it.





Ricky said:
Hi Dave,
I appreciate your response. The data in the cells would be either "X"s
or "1"s. After running your macro, I've elected to go with the "1"s
instead.

On your post:
With wks
FirstRow = 2 'header row? [Yes]
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2 'names in column A
Question:
As the search criteria is based on Column A's names, should it have been
{First Col = 1}?

Another part:
'just move it up and overwrite anything there?
.Cells(iRow - 1, iCol).Value = .Cells(iRow, iCol).Value
Question:
No, not overwriting the X's that is already on the previous row. I
wanted to paste special, skip blanks, so that the data is not
overwritten. The X's will just keep adding up a row until all of the
X's (or 1's), all amalgamate onto the first row of the groupings.

So far, your code does delete the multiple names, leaving only 1
distinct name each. But, I am having trouble working around the
consolidating all of the X's from multiple lines into just one line for
each group.

Thanks Dave for helping me.

Ricky
Click to expand...
 
Hi Dave,
To answer the second question:
No, I didn't want the values to be strung together within a single cell
ie, X,X,X...
Instead, I wanted to copy the last row, within the group, and paste the
values up one row. But I don't want to paste and overwrite the values.

So, the idea is to choose Paste Special instead and check the Skip
Blanks feature. This would then paste the X's, from the previous row,
onto the blank cells only. This way, I would retain the values and have
the bottom row's values add to the upper row on the blank cells only.
Thus, consolidating two rows into one.

Your Sub Testme1 didn't add up onto the blank cells. Testme 2 is for
stringing the values together. Unfortunately, not what I was looking
for. The result of Sub Testme3 didn't paste to blank cells either.

I know your macro is close. I just couldn't decipher where to make that
modification so that it'll only paste the X's onto the blank cells only?
(Then, delete the last row, loop the same name grouping, copy and paste
up one row, until all of the X's from the multiple rows are all on the
top row.)

Much appreciated, Dave.

Ricky
 
I'm still confused.

Say you start with this:

A B C D E
Bill 1 2
Bill 3 4 5
Bill 6 7
Sue 8
Sue 9
Bob 10 11
Bob 12 13

do you want to end up with this:
A B C D E
Bill 1 3 6 5 7
Sue 9 8
Bob 10 12 11 13

or:
A B C D E
Bill 1 2 4 5 7
Sue 9 8
Bob 10 12 11 13


If it's the first one, then use the first version (testme) of the macro.
If it's the second one, the use the 3rd version (testme3).

If it's something else, I'm more lost.

All of the routines just started at the bottom of column A and worked their way
up to the firstrow.

In testme:
If IsEmpty(.Cells(iRow, iCol)) Then
'do nothing
Else
'just move it up and overwrite anything there?
.Cells(iRow - 1, iCol).Value = .Cells(iRow, iCol).Value
End If

If the cell in the bottom row is empty, then don't do anything.
if the cell in the bottom row has something in it, then overwrite the cell
above.

In testme3:

If IsEmpty(.Cells(iRow - 1, iCol)) = False Then
'do nothing
Else
'just move it up and overwrite anything there?
.Cells(iRow - 1, iCol).Value = .Cells(iRow, iCol).Value
End If

If the cell above is not empty, then leave it alone.
If the cell above is empty, just plop the cell below into it.

(not too different, huh?)
 
Hi Dave,
First of all, please allow me to extend my gratitude to you. You have
been extremely helpful.

I have been testing your solution on other spreadsheets. And Yes, they
definitely work. You got it right the first time, with the Sub Testme
code. It took me all day to realize why your code didn't work on my
spreadsheet. I just don't have answer to work around it.

First, to answer your question (yes, they are all X's according to the
result of an If..Then.. formula in the spreadsheet). So the spreadsheet
now is:

A B C D E
Bob X
Bob X
Bob X X X
Sue X
Sue X X
Sue X X
Wil X
Wil X
Wil X

Your code would make it:
A B C D E
Bob X X X X
Sue X X X X
Wil X X X

All of the routines starting at the bottom of column A and worked their
way up to the firstrow is definitely correct...and exactly what I
wanted.

Now the problem: I had to copy and paste as values in order to rid all
of the formulas before I run your macro. But when I run it, it just
copies the bottom line and overwrites the row above until all multiple
rows are gone. Leaving the original last row standing.

I attitribute this problem because it's trying to check the cell above
for an empty cell. But it sees this [']. My guess is that the
apostrophe fools the code in thinking there's a value in it; and
therefore skips the paste. Furthermore, the X's does have an apostrophe
like such ['X] shown in the formula bar. I have no idea where this
apostrophe comes from. None of my other spreadsheets have that. Any
ideas?

Thanks,
Ricky
 
Ahhhhh. Good point. Those formulas that evaluate to "" and converted to values
aren't empty.

Instead of checking for:
If IsEmpty(.Cells(iRow, iCol)) then

you could do this:
if .cells(irow,icol).value = "" then


Another option is to clean up that "mess" that's already there.
If all your data will be values, then you could do this:
Set wks = Worksheets("sheet1")

With wks
.usedrange.value = .usedrange.value
FirstRow = 2 'header row?
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
FirstCol = 2 'names in column A
.....

That .usedrange.value = .usedrange.value will convert formulas to values and
also not leave that stuff behind.





Ricky said:
Hi Dave,
First of all, please allow me to extend my gratitude to you. You have
been extremely helpful.

I have been testing your solution on other spreadsheets. And Yes, they
definitely work. You got it right the first time, with the Sub Testme
code. It took me all day to realize why your code didn't work on my
spreadsheet. I just don't have answer to work around it.

First, to answer your question (yes, they are all X's according to the
result of an If..Then.. formula in the spreadsheet). So the spreadsheet
now is:

A B C D E
Bob X
Bob X
Bob X X X
Sue X
Sue X X
Sue X X
Wil X
Wil X
Wil X

Your code would make it:
A B C D E
Bob X X X X
Sue X X X X
Wil X X X

All of the routines starting at the bottom of column A and worked their
way up to the firstrow is definitely correct...and exactly what I
wanted.

Now the problem: I had to copy and paste as values in order to rid all
of the formulas before I run your macro. But when I run it, it just
copies the bottom line and overwrites the row above until all multiple
rows are gone. Leaving the original last row standing.

I attitribute this problem because it's trying to check the cell above
for an empty cell. But it sees this [']. My guess is that the
apostrophe fools the code in thinking there's a value in it; and
therefore skips the paste. Furthermore, the X's does have an apostrophe
like such ['X] shown in the formula bar. I have no idea where this
apostrophe comes from. None of my other spreadsheets have that. Any
ideas?

Thanks,
Ricky
Click to expand...
 
Hi Dave,
That was definitely the answer. It worked beautifully. Thank-you so
much. You've helped me tremendously.

Thanks again,
Ricky
 
Back
Top