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
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 |
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 |
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
Book1 | |||||
---|---|---|---|---|---|
B | C | D | |||
1 | Before | After | |||
2 | Monday | ||||
3 | Friday | Friday | |||
4 | Friday | ||||
5 | Sunday | Sunday | |||
6 | Sunday | ||||
7 | Sunday | ||||
8 | Sunday | ||||
9 | Monday | Monday | |||
10 | Monday | ||||
11 | Monday | ||||
12 | Friday | Friday | |||
13 | Friday | ||||
14 | Monday | Monday | |||
15 | Monday | ||||
16 | Friday | Friday | |||
17 | Friday | ||||
Sheet1 |
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
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 | |||
1 | Before | ||
2 | Sunday | ||
3 | Sunday | ||
4 | Sunday | ||
5 | Sunday | ||
6 | Monday | ||
7 | Monday | ||
8 | Monday | ||
9 | Friday | ||
10 | Friday | ||
Sheet1 |
Book1 | |||
---|---|---|---|
B | |||
1 | After | ||
2 | Sunday | ||
3 | |||
4 | |||
5 | |||
6 | Monday | ||
7 | |||
8 | |||
9 | Friday | ||
10 | |||
Sheet1 |
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 1 Before 2 Sunday 3 Sunday 4 Sunday 5 Sunday 6 Monday 7 Monday 8 Monday 9 Friday 10 Friday Sheet1
Book1
B 1 After 2 Sunday 3 4 5 6 Monday 7 8 9 Friday 10 Sheet1
Thank you very much, the formula is very helpful for data formatting2nd 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
B C D 1 Before After 2 Monday 3 Friday Friday 4 Friday 5 Sunday Sunday 6 Sunday 7 Sunday 8 Sunday 9 Monday Monday 10 Monday 11 Monday 12 Friday Friday 13 Friday 14 Monday Monday 15 Monday 16 Friday Friday 17 Friday 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
Glad to assist, If you have any further questions, please don't hesitate to ask/share with usThank you very much, the formula is very helpful for data formatting
HelloThank you very much, the formula is very helpful for data formatting
Hello sorry sorry I need help, why do i find error?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 1 Before 2 Sunday 3 Sunday 4 Sunday 5 Sunday 6 Monday 7 Monday 8 Monday 9 Friday 10 Friday Sheet1
Book1
B 1 After 2 Sunday 3 4 5 6 Monday 7 8 9 Friday 10 Sheet1
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
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 |
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 |