Excel Merging Based on Another Column

Question

I was able to find a merging macro at 

https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html?page_comment=4

This allowed me to merge unique codes in column A (over 7000 rows). The next thing I need is to merge the two columns to the right of it based on the merging of the column A.

Example: I need column B & C to be merged based on Column A. I can't do the merge macro listed above that I did for column A because the '50' in column B merges across Column A (01, 02, 03). Instead, I need each to be merged in order regardless of what the next group's value is.

What I have:

00	35	33
35	33
35	33
35	33
35	33
35	33
35	33
01	50	51
50	51
50	51
02	50	49
50	49
50	49
03	50	55
50	55
50	55
04	25	25
25	25
25	25
25	25

What I need:

00	35	33	Item 1
Item 2
Item 3
Item 4
Item 5
Item 6
Item 7
01	50	51	Item 8
Item 9
Item 10
02	50	49	Item 11
Item 12
Item 13
03	50	55	Item 14
Item 15
Item 16
04	25	25	Item 17
Item 18
Item 19
Item 20

Any help would be appreciated!!!!

Answer 1

In your "after" illustration I do not see any merging.

I see all blanks in Column A removed and data rows removed.

Have you tried Date>Filter>Advanced Filter for unique values in column A?

Or try this macro.

Sub Delete_Blank_Rows()

Dim RowNdx As Long

Dim Lastrow As Long

Lastrow = Cells(Rows.Count, "A").End(xlUp).Row

    For RowNdx = Lastrow To 1 Step -1

        If Cells(RowNdx, "A").Value = "" Then

            Rows(RowNdx).Delete

        End If

    Next RowNdx

End Sub

Gord

Answer 2

I determined the answer. I will post it here in case someone else faces this issue. I tweaked the original code and saved it in the Macro. Before doing any sorting, Select all rows of column A, then hit F5 to run....

Sub MergeSameCell()

'Updateby20131127

Dim Rng As Range, xCell As Range

Dim xRows As Integer

xTitleId = "Multiple Merge & Center"

Set WorkRng = Application.Selection

Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

Application.ScreenUpdating = False

Application.DisplayAlerts = False

xRows = WorkRng.Rows.Count

For Each Rng In WorkRng.Columns

    For i = 1 To xRows - 1

        For j = i + 1 To xRows

            If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then

                Exit For

            ElseIf Rng.Cells(i, 1).Value = "" Then

                Exit For

            End If

        Next

        WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1)).Merge

        WorkRng.Parent.Range(Rng.Cells(i, 2), Rng.Cells(j - 1, 2)).Merge

        WorkRng.Parent.Range(Rng.Cells(i, 3), Rng.Cells(j - 1, 3)).Merge

        i = j - 1

    Next

Next

Application.DisplayAlerts = True

Application.ScreenUpdating = True

End Sub

Answer 3

Hello Gord,

Thank you for your reply. Pasting the "what I need" didn't originally turn out the way it should. The 'Merge and Center' for column B is taking all the 35s and putting just one and all the 50s and putting one per value in column A (basically not merging just on value but on how column A is merged.

Your macro works well but I can't delete rows because I have other values in columns and rows that are unique. It needs to remain 7000+ rows. I apologize, I should have mentioned that.