重複するVBAを削除する

このコードでは、列 "B"に重複があるかどうかを確認します。重複している場合は、そのCell + 2個のセルを右側に削除する必要があります。

（B12）=（B13）の場合、（B13）、（B14）、（B15）を削除する必要があります

duplicateremoverはコードの下部にあり、機能していません。 B列には約50の異なる数があるはずですが、2しか見つかりません。

Sub Expa()
Sheets("STUDYBOARD_ID Blank").Select
'For / Next unik liste
For i = 2 To 18288
If IsEmpty(Sheets("Base").Cells(i, 8)) = True Then
Worksheets("STUDYBOARD_ID Blank").Cells(i, 2) = Worksheets("Base").Cells(i, 2)
Worksheets("STUDYBOARD_ID Blank").Cells(i, 3) = Worksheets("Base").Cells(i, 9)
Worksheets("STUDYBOARD_ID Blank").Cells(i, 4) = Worksheets("Base").Cells(i, 10)
End If
Next i
'For / Next fuld liste
For i = 2 To 18288
If IsEmpty(Sheets("Base").Cells(i, 8)) = True Then
Worksheets("STUDYBOARD_ID Blank").Cells(i, 7) = Worksheets("Base").Cells(i, 2)
Worksheets("STUDYBOARD_ID Blank").Cells(i, 8) = Worksheets("Base").Cells(i, 9)
Worksheets("STUDYBOARD_ID Blank").Cells(i, 9) = Worksheets("Base").Cells(i, 10)
End If
Next i
'Overskrifter unik liste
Worksheets("STUDYBOARD_ID Blank").Cells(1, 2).Font.Bold = True
Cells(1, 2) = "Unik liste"
Cells(2, 2) = "PROGRAM_CODE"
Cells(2, 3) = "FACULTY_ID"
Cells(2, 4) = "PROGRAM_TYPE_LETTER"
'Overskrifter fuld liste
Worksheets("STUDYBOARD_ID Blank").Cells(1, 6).Font.Bold = True '
Cells(1, 6) = "Fuld liste"
Cells(2, 7) = "PROGRAM_CODE"
Cells(2, 8) = "FACULTY_ID"
Cells(2, 9) = "PROGRAM_TYPE_LETTER"
'Sorterer for overblik unik liste
ActiveWorkbook.Worksheets("STUDYBOARD_ID Blank").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("STUDYBOARD_ID Blank").Sort.SortFields.Add Key:=Range( _
"B2:B18288"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("STUDYBOARD_ID Blank").Sort
.SetRange Range("B2:E18288")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("STUDYBOARD_ID Blank").Columns("A:F").AutoFit
'Sorterer for overblik fuld liste
ActiveWorkbook.Worksheets("STUDYBOARD_ID Blank").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("STUDYBOARD_ID Blank").Sort.SortFields.Add Key:=Range( _
"G2:G18288"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("STUDYBOARD_ID Blank").Sort
.SetRange Range("G2:J18288")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("STUDYBOARD_ID Blank").Columns("F:J").AutoFit

Dim Information1 As Range
Dim Information2 As Long
Information2 = ActiveSheet.Range("B" & Rows.Count).End(xlUp).row
Set Information1 = ActiveSheet.Range("B1:D" & Information2)
Information1.RemoveDuplicates Columns:=3, Header:=xlYes

End Sub