vba to merge Rows based on Values in Column A

A

aravindhan_31

Well-known Member
Joined
Apr 11, 2006
Messages
672
Office Version
  1. 365
  2. 2019
  3. 2016
Platform
  1. Windows
Hi,

I have data in columns A to U like. Column A data as below ( data starts from row 2)
Colum A
A
A
A
B
B
C
D
E
E
E
now need to merge few columns C, E, O & P based on values in A, in all these columns,
rows 2 to 4 should be merged ( All "A"s) , Rows 5 & 6 (All "B"s) should be merged & rows 7 & 8 should be merged since it ha only one row ( "C" & "D")
again All E's to be merged.

Can any one help me with the macro for this:)

thanks in advance
Arvind
 
Sort by date Sort by votes
your data should be in "Sheet1"

and change the below statements as per your choice

If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Range(Cells(i, 1), Cells(i - 1, 1)).Select
Selection.Merge
Range(Cells(i, 2), Cells(i - 1, 2)).Select
Selection.Merge
Range(Cells(i, 3), Cells(i - 1, 3)).Select
Selection.Merge
Range(Cells(i, 4), Cells(i - 1, 4)).Select
Selection.Merge

1 stands for A, 2 stands B , and 3 for C and 4 for D. I am doing merging in only these 4 columns. Change these lines as per your requirement, add more if you want to merge more columns.
 
Upvote 0

Excel Facts

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
bhos123 said:
Code: 
Sub macro1()

Dim x1 As Long
x1 = 2
For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Backupdata" Then
        exists = True
        Sheets("Backupdata").Visible = True
    End If
Next i

If Not exists Then
    Worksheets.Add.Name = "Backupdata"
    x1 = 1
    Sheets("Sheet1").Select
    Cells.Select
    Selection.Copy
    Sheets("Backupdata").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If

Dim lastRow, lastRow_b As Long
Dim lastcolumn, lastcolumn_b As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("Sheet1").Select
lastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
lastcolumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count

Sheets("Backupdata").Select
lastRow_b = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
lastcolumn_b = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count

If x1 = 1 Then

Sheets("Sheet1").Select
    Rows("3:3").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(3, 1), Cells(lastRow, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range(Cells(2, 1), Cells(lastRow, lastcolumn))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    

For i = lastRow To 4 Step -1

If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Range(Cells(i, 1), Cells(i - 1, 1)).Select
Selection.Merge
Range(Cells(i, 2), Cells(i - 1, 2)).Select
Selection.Merge
Range(Cells(i, 3), Cells(i - 1, 3)).Select
Selection.Merge
Range(Cells(i, 4), Cells(i - 1, 4)).Select
Selection.Merge

End If

Next
End If

If x1 = 2 Then
If lastRow_b = lastRow Then
Sheets("Backupdata").Visible = False
Exit Sub
End If
Sheets("Backupdata").Visible = True
Sheets("Sheet1").Select
    Range(Cells(lastRow_b + 1, 1), Cells(lastRow, lastcolumn)).Select
    Selection.Copy
    Sheets("Backupdata").Select
    Range("A" & lastRow_b + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Sheets("Sheet1").Select
    Rows(lastRow_b + 1).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(lastRow_b + 1, 1), Cells(lastRow, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range(Cells(lastRow_b, 1), Cells(lastRow, lastcolumn))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    

For i = lastRow To lastRow_b + 2 Step -1

If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Range(Cells(i, 1), Cells(i - 1, 1)).Select
Selection.Merge
Range(Cells(i, 2), Cells(i - 1, 2)).Select
Selection.Merge
Range(Cells(i, 3), Cells(i - 1, 3)).Select
Selection.Merge
Range(Cells(i, 4), Cells(i - 1, 4)).Select
Selection.Merge
   

End If
Next
End If

Sheets("Backupdata").Visible = False
Application.ScreenUpdating = True


End Sub
Click to expand...

Hello @bhos123,

Thank you for your codes! I will let you know the result once I get the chance to try it out. Once again, thank you for the help! Really appreciate it!
 
Upvote 0
bhos123 said:
Code: 
Sub macro1()

Dim x1 As Long
x1 = 2
For i = 1 To Worksheets.Count
    If Worksheets(i).Name = "Backupdata" Then
        exists = True
        Sheets("Backupdata").Visible = True
    End If
Next i

If Not exists Then
    Worksheets.Add.Name = "Backupdata"
    x1 = 1
    Sheets("Sheet1").Select
    Cells.Select
    Selection.Copy
    Sheets("Backupdata").Select
    Range("A1").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
End If

Dim lastRow, lastRow_b As Long
Dim lastcolumn, lastcolumn_b As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False

Sheets("Sheet1").Select
lastRow = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
lastcolumn = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count

Sheets("Backupdata").Select
lastRow_b = ActiveSheet.UsedRange.Row - 1 + ActiveSheet.UsedRange.Rows.Count
lastcolumn_b = ActiveSheet.UsedRange.Column - 1 + ActiveSheet.UsedRange.Columns.Count

If x1 = 1 Then

Sheets("Sheet1").Select
    Rows("3:3").Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(3, 1), Cells(lastRow, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range(Cells(2, 1), Cells(lastRow, lastcolumn))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    

For i = lastRow To 4 Step -1

If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Range(Cells(i, 1), Cells(i - 1, 1)).Select
Selection.Merge
Range(Cells(i, 2), Cells(i - 1, 2)).Select
Selection.Merge
Range(Cells(i, 3), Cells(i - 1, 3)).Select
Selection.Merge
Range(Cells(i, 4), Cells(i - 1, 4)).Select
Selection.Merge

End If

Next
End If

If x1 = 2 Then
If lastRow_b = lastRow Then
Sheets("Backupdata").Visible = False
Exit Sub
End If
Sheets("Backupdata").Visible = True
Sheets("Sheet1").Select
    Range(Cells(lastRow_b + 1, 1), Cells(lastRow, lastcolumn)).Select
    Selection.Copy
    Sheets("Backupdata").Select
    Range("A" & lastRow_b + 1).Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False

Sheets("Sheet1").Select
    Rows(lastRow_b + 1).Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(lastRow_b + 1, 1), Cells(lastRow, 1)) _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range(Cells(lastRow_b, 1), Cells(lastRow, lastcolumn))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    

For i = lastRow To lastRow_b + 2 Step -1

If Cells(i, 1).Value = Cells(i - 1, 1).Value Then
Range(Cells(i, 1), Cells(i - 1, 1)).Select
Selection.Merge
Range(Cells(i, 2), Cells(i - 1, 2)).Select
Selection.Merge
Range(Cells(i, 3), Cells(i - 1, 3)).Select
Selection.Merge
Range(Cells(i, 4), Cells(i - 1, 4)).Select
Selection.Merge
   

End If
Next
End If

Sheets("Backupdata").Visible = False
Application.ScreenUpdating = True


End Sub
Click to expand...

Hello @bhos123,

I have tried your code but it gives me runtime error 1004 - object defined error or application error. Also, can you explain a little about the code? What is the back up data for? I am new to this so it is quite hard for me to understand what is going on. :confused:
 
Upvote 0
which line you are getting error? do you have the data in 'Sheet1' tab, even then if you are getting the error. mail me the sample data to mahipaldotisiattherategmaildotcom

replace dot attherate with corresponding symbols.
 
Last edited:
Upvote 0
bhos123 said:
which line you are getting error? do you have the data in 'Sheet1' tab, even then if you are getting the error. mail me the sample data to mahipaldotisiattherategmaildotcom

replace dot attherate with corresponding symbols.
Click to expand...

The worksheet that I need to do the merging is called Sheet3 (I rename the tab to be Line1) so I replaced all Sheet1 to Sheet3 on the codes. I put the codes on Sheet3. I saved and run the userform but it did nothing. I will send you my spreadsheet today.
 
Upvote 0
can you clearly tell me step-by-step.

1) where is your first data present
2) where do u want to see that results
3) where will you add more data
4) where do you u want see the updated results.

you never told me that you want to the merging in separate spreadsheet other than your data sheet, In my code the merging will happen on same spreadsheet. Send me the details step-by-step(I have received your excel file, may be you can use the same excel file and explain me step-by-step what you want.)
 
Upvote 0
bhos123 said:
Hi,

change the below line


For i = lastRow To 2 Step -1

to


For i = lastRow To 3 Step -1

this will merge from row 3 onwards.
Click to expand...
Hello, i know its an old question. but code works like new :D i successfully adopted your code if u don t mind ;). I have one question, is it possible to revers this action. I mean to unmerge cells, merged before, like some undo macro for this macro?
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Question Question
VBA Script to merge cells based on cell value
Replies
1
Views
108
Joe4
Joe4
C
  • Question Question
How to merge the data in a number of cells in a list based on a reference
Replies
9
Views
157
Peter_SSs
Peter_SSs
A
  • Solved
Sum of Row with Letters and Merged Numbers in Different Cells
Replies
3
Views
256
Joe4
Joe4
B
  • Solved
VBA enter today's date if anything is typed in cell
2
Replies
19
Views
581
Joe4
Joe4
O
  • Solved
I want it all! Using single lookup command to return both multiple Rows and Columns
Replies
4
Views
453
Fluff
Fluff

Forum statistics

Threads
1,223,744
Messages
6,174,252
Members
452,553
Latest member
red83

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top