merge duplicate data

S

Sefty

Board Regular
Joined
Apr 5, 2022
Messages
68
Office Version
  1. 365
Platform
  1. Windows
Book1
BCDE
1Before After
2Sunday Sunday
3Sunday
4Sunday
5Sunday
6MondayMonday
7Monday
8Monday
9FridayFriday
10Friday
11
Sheet1


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

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.
Sort by date Sort by votes
Kindly give a shot @Sefty

Book1
BCD
1Before After
2Sunday Sunday
3Sunday
4Sunday
5Sunday
6MondayMonday
7Monday
8Monday
9FridayFriday
10Friday
Sheet1


VBA Code: 
Option Explicit
Sub test()
Dim ws As Worksheet
Set ws = Sheets("sheet1")
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Comparemode = vbTextCompare
Dim a As Variant, t As Variant
Dim i%, c1%, c2%
Application.ScreenUpdating = False
On Error Resume Next

'Store B1 to last row into array
a = ws.Range("b1:b" & ws.Cells(Rows.Count, "b").End(xlUp).Row).Value

ws.[d2:d5000].Clear

'Loop through array and save in Dictionary
For i = 2 To UBound(a, 1)
    If Not dict.exists(a(i, 1)) And a(i, 1) <> "" Then 'If value not empty and sunday not existing before then add to dict
        dict.Add a(i, 1), i
    ElseIf dict.exists(a(i, 1)) And Not dict.exists(a(i + 1, 1)) Then 'If already exists but below value not yet exist then save i as last row item
        dict(a(i, 1)) = dict(a(i, 1)) & "#" & i
    End If
Next i

t = dict.items

For i = 0 To UBound(t, 1)
    c1 = Replace(Left(t(i), InStr(t(i), "#")), "#", "")
    c2 = Replace(Right(t(i), InStr(t(i), "#")), "#", "")
    With Range(Cells(c1, "d"), Cells(c2, "d"))
        .Merge
        .Value = dict.Keys()(i)
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
Next i

Application.ScreenUpdating = True
End Sub
 
Upvote 0
2nd option, if you got duplicate values ( for example sunday in a2:a5 , then appear again in a10:15) then you need to try below code instead.

Book1
BCD
1Before After
2Monday
3FridayFriday
4Friday
5Sunday Sunday
6Sunday
7Sunday
8Sunday
9MondayMonday
10Monday
11Monday
12FridayFriday
13Friday
14MondayMonday
15Monday
16FridayFriday
17Friday
Sheet1


VBA Code: 
Option Explicit
Sub test()
Dim ws As Worksheet
Set ws = Sheets("sheet1")
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Comparemode = vbTextCompare
Dim a As Variant, t As Variant
Dim i%, c1%, c2%, k%
Application.ScreenUpdating = False
On Error Resume Next
'Store B1 to last row into array
a = ws.Range("b1:b" & ws.Cells(Rows.Count, "b").End(xlUp).Row).Value

ws.[d2:d5000].Clear

'Loop through array and save in Dictionary
For i = 2 To UBound(a, 1)
    If Not dict.exists(a(i, 1)) And a(i, 1) <> "" Then 'If value not empty and sunday not existing before then add to dict
        dict.RemoveAll 'To anticipate/remove if 1st value monday 2ndvalue not monday, therefore need to remove dict
        dict.Add a(i, 1), i
    ElseIf dict.exists(a(i, 1)) And Not dict.exists(a(i + 1, 1)) Then 'If already exists but below value not yet exist then save i as last row item
        dict(a(i, 1)) = dict(a(i, 1)) & "#" & i
        k = k + 1
    End If
    
    If k = 1 Then
              t = dict.items
                    c1 = Replace(Left(t(0), InStr(t(0), "#")), "#", "")
                    c2 = Replace(Right(t(0), InStr(t(0), "#")), "#", "")
             With Range(Cells(c1, "d"), Cells(c2, "d"))
                .Merge
                .Value = dict.Keys()(k - 1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
         k = 0
         
    End If
Next i


Application.ScreenUpdating = True
End Sub
 
Upvote 0
Another option if your intention was to merge in situ
VBA Code: 
Sub Merge_Same()
    Dim c As Range
    Application.DisplayAlerts = 0
StartMerge:
    For Each c In Sheet1.Range("B2", Cells(Rows.Count, "B").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

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


Book1
B
1After
2Sunday
3
4
5
6Monday
7
8
9Friday
10
Sheet1
 
Upvote 0
kevin9999 said:
Another option if your intention was to merge in situ
VBA Code: 
Sub Merge_Same()
    Dim c As Range
    Application.DisplayAlerts = 0
StartMerge:
    For Each c In Sheet1.Range("B2", Cells(Rows.Count, "B").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

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


Book1
B
1After
2Sunday
3
4
5
6Monday
7
8
9Friday
10
Sheet1
Click to expand...

Thank you very much, the formula is very helpful for data formatting (y) 🙏
 
Upvote 0
RudRud said:
2nd option, if you got duplicate values ( for example sunday in a2:a5 , then appear again in a10:15) then you need to try below code instead.

Book1
BCD
1Before After
2Monday
3FridayFriday
4Friday
5Sunday Sunday
6Sunday
7Sunday
8Sunday
9MondayMonday
10Monday
11Monday
12FridayFriday
13Friday
14MondayMonday
15Monday
16FridayFriday
17Friday
Sheet1


VBA Code: 
Option Explicit
Sub test()
Dim ws As Worksheet
Set ws = Sheets("sheet1")
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
dict.Comparemode = vbTextCompare
Dim a As Variant, t As Variant
Dim i%, c1%, c2%, k%
Application.ScreenUpdating = False
On Error Resume Next
'Store B1 to last row into array
a = ws.Range("b1:b" & ws.Cells(Rows.Count, "b").End(xlUp).Row).Value

ws.[d2:d5000].Clear

'Loop through array and save in Dictionary
For i = 2 To UBound(a, 1)
    If Not dict.exists(a(i, 1)) And a(i, 1) <> "" Then 'If value not empty and sunday not existing before then add to dict
        dict.RemoveAll 'To anticipate/remove if 1st value monday 2ndvalue not monday, therefore need to remove dict
        dict.Add a(i, 1), i
    ElseIf dict.exists(a(i, 1)) And Not dict.exists(a(i + 1, 1)) Then 'If already exists but below value not yet exist then save i as last row item
        dict(a(i, 1)) = dict(a(i, 1)) & "#" & i
        k = k + 1
    End If
   
    If k = 1 Then
              t = dict.items
                    c1 = Replace(Left(t(0), InStr(t(0), "#")), "#", "")
                    c2 = Replace(Right(t(0), InStr(t(0), "#")), "#", "")
             With Range(Cells(c1, "d"), Cells(c2, "d"))
                .Merge
                .Value = dict.Keys()(k - 1)
                .HorizontalAlignment = xlCenter
                .VerticalAlignment = xlCenter
            End With
         k = 0
        
    End If
Next i


Application.ScreenUpdating = True
End Sub
Click to expand...
Thank you very much, the formula is very helpful for data formatting 🙏
 
Upvote 0
Sefty said:
Thank you very much, the formula is very helpful for data formatting 🙏
Click to expand...
Glad to assist, If you have any further questions, please don't hesitate to ask/share with us :)
 
Upvote 0
Sefty said:
Thank you very much, the formula is very helpful for data formatting (y) 🙏
Click to expand...
Hello
kevin9999 said:
Another option if your intention was to merge in situ
VBA Code: 
Sub Merge_Same()
    Dim c As Range
    Application.DisplayAlerts = 0
StartMerge:
    For Each c In Sheet1.Range("B2", Cells(Rows.Count, "B").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

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


Book1
B
1After
2Sunday
3
4
5
6Monday
7
8
9Friday
10
Sheet1
Click to expand...
Hello sorry sorry I need help, why do i find error?
1688996179645.png
1688996204161.png
 
Upvote 0
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.
VBA Code: 
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
BCD
1Before After
2Sunday
3Sunday
4Sunday
5Sunday
6Monday
7Monday
8Monday
9Friday
10Friday
Sheet1


After:
Book1
BCD
1Before After
2Sunday Sunday
3Sunday
4Sunday
5Sunday
6MondayMonday
7Monday
8Monday
9FridayFriday
10Friday
Sheet1
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Merging duplicate values
Replies
1
Views
183
DanteAmor
DanteAmor
H
  • Solved
Merging Duplicate Rows and time entries
Replies
5
Views
294
alansidman
A
D
  • Solved
Merge and Center one Row
Replies
3
Views
75
Kaper
Kaper
S
  • Question Question
VBA Script to merge cells based on cell value
Replies
1
Views
135
Joe4
Joe4
S
  • Question Question
Merge a sheet with specific name from multiple workbooks.
Replies
3
Views
360
shirazsafa
S

Forum statistics

Threads
1,223,889
Messages
6,175,224
Members
452,620
Latest member
dsubash

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