merge duplicate data

[Sefty]

Book1
	B	C	D	E
1	Before		After
2	Sunday		Sunday
3	Sunday
4	Sunday
5	Sunday
6	Monday		Monday
7	Monday
8	Monday
9	Friday		Friday
10	Friday
11
Sheet1

Hello if i want to merge duplicate data, from before to after is it possible with VBA?
Thanks

 

[Peter_SSs]

Thank you very much, the formula is very helpful for data formatting

The marked solution has been changed accordingly. In your future questions, please mark the post as the solution that actually answered your question, instead of your feedback message as it will help future readers. No further action is required for this thread.

 

[Sefty]

I note you changed the column reference from my suggested code in post #4 from column B to column D. I'm guessing that you didn't have any values in column D before running the code, and that your real intention is like you described in your original post - that is, take unmerged items in column B and merge them into column D? If that is the case, try the following code, which copies items from column B first into column D, then merges like items. If this is not what you wanted, then you'll need to give a much more detailed description of your intended outcome.

Sub Merge_Same()
    Dim c As Range
    Application.DisplayAlerts = 0
    Sheet1.Range("B2", Cells(Rows.Count, "B").End(xlUp)).Copy Sheet1.Range("D2")
StartMerge:
    For Each c In Sheet1.Range("D2", Cells(Rows.Count, "D").End(xlUp))
        If c = c.Offset(1) And c.Offset(1) <> "" Then
            Sheet1.Range(c, c.Offset(1)).Merge
            GoTo StartMerge
        End If
    Next c
    Application.DisplayAlerts = 1
End Sub

Before:

Book1
	B	C	D
1	Before		After
2	Sunday
3	Sunday
4	Sunday
5	Sunday
6	Monday
7	Monday
8	Monday
9	Friday
10	Friday
Sheet1

After:

Book1
	B	C	D
1	Before		After
2	Sunday		Sunday
3	Sunday
4	Sunday
5	Sunday
6	Monday		Monday
7	Monday
8	Monday
9	Friday		Friday
10	Friday
Sheet1

I already know the error, it's been resolved.
But I don't know, if I want to repeat the merge for sheet 2, how about sheet 3? I have tried but it seems there is a missing code. Sorry please help

Sub Merge_Nom_PN_PP_KP_Prop()
    Dim c As Range
    Application.DisplayAlerts = 0
StartMerge:
    Sheets("PN 2").Select
    For Each c In Sheets("PN 2").Range("D2", Cells(Rows.Count, "D").End(xlUp))
        If c = c.Offset(1) And c.Offset(1) <> "" Then
            Sheets("PN 2").Range(c, c.Offset(1)).Merge
            GoTo StartMerge
        End If
    Next c
    Application.DisplayAlerts = 1
    
    End With
    
    Sheets("PN 3").Select
    For Each c In Sheets("PN 3").Range("D2", Cells(Rows.Count, "D").End(xlUp))
        If c = c.Offset(1) And c.Offset(1) <> "" Then
            Sheets("PN 3").Range(c, c.Offset(1)).Merge
            GoTo StartMerge
        End If
    Next c
    Application.DisplayAlerts = 1
    
    End With
     
End Sub

 

[kevin9999]

If you want to apply this to multiple sheets, try the following code. I'm assuming that on each sheet the data you want to merge is already in column D (starting from D2) based on the code you posted in post #12. If this doesn't do what you want, then I really will need to see your actual file which you can share via Google Drive, Dropbox, or similar file sharing platform.

Option Explicit
Sub Merge_Nom_PN_PP_KP_Prop()
    Dim ws As Worksheet, c As Range
    Application.DisplayAlerts = 0
    
    For Each ws In Sheets(Array("PN 2", "PN 3"))    '<~~ *** Add as many sheet names here as you need ***
StartMerge:
        For Each c In ws.Range("D2", ws.Cells(Rows.Count, "D").End(xlUp))
            If c = c.Offset(1) And c.Offset(1) <> "" Then
                ws.Range(c, c.Offset(1)).Merge
                GoTo StartMerge
            End If
        Next c
    Next ws
    
    Application.DisplayAlerts = 1
End Sub

 

[Sefty]

If you want to apply this to multiple sheets, try the following code. I'm assuming that on each sheet the data you want to merge is already in column D (starting from D2) based on the code you posted in post #12. If this doesn't do what you want, then I really will need to see your actual file which you can share via Google Drive, Dropbox, or similar file sharing platform.

Option Explicit
Sub Merge_Nom_PN_PP_KP_Prop()
    Dim ws As Worksheet, c As Range
    Application.DisplayAlerts = 0
   
    For Each ws In Sheets(Array("PN 2", "PN 3"))    '<~~ *** Add as many sheet names here as you need ***
StartMerge:
        For Each c In ws.Range("D2", ws.Cells(Rows.Count, "D").End(xlUp))
            If c = c.Offset(1) And c.Offset(1) <> "" Then
                ws.Range(c, c.Offset(1)).Merge
                GoTo StartMerge
            End If
        Next c
    Next ws
   
    Application.DisplayAlerts = 1
End Sub

thanks for the help, very helpful in formatting the data.
Thanks for the time and knowledge

 

[kevin9999]

You're welcome, and thanks for the feedback

 

[Peter_SSs]

If you are interested, here is another way that could require a lot less looping and it merges the whole of each area at once rather than one row at a time.
For the moment, I have assumed that each sheet will have at least one area to merge. If it is possible that there could be no areas to merge on one of the worksheets than the code will need a little more.

Sub Merge_Values()
  Dim ws As Worksheet
  Dim rA As Range
  
  For Each ws In Sheets(Array("PN 2", "PN 3"))
    With ws.Range("D2", ws.Range("D" & Rows.Count).End(xlUp))
      .Value = .Worksheet.Evaluate("if(" & .Address & "=" & .Offset(-1).Address & ",""""," & .Address & ")")
      For Each rA In .SpecialCells(xlBlanks).Areas
        rA.Offset(-1).Resize(rA.Count + 1).Merge
      Next rA
    End With
  Next ws
End Sub