Simplify the VBA Code

Hello Everyone, I have been assigned the work of Inventory management of a nearby super shoppe where I have to work on around 18000 SKU's for which the first job I have to do is to remove duplication of these 18000 line items which can be due to spelling error or such other mistakes. I have written the code but this code is taking around 20 minutes to run on 18000 line items. I want this code to be fast and if possible simpler.

Eg.
DOVE CREAM BAR 100G
DOVE CREAM BAR 100GM

DOVE PINK BAR 50G
DOVE PINK BAR 50GM

PARLE 20-20 GOLD CASHEW ALMOND COOKIES 600 GM
PARLE 20-20 GOLD CASHEW ALOMND COOKIES 600 GM

All these are duplicates

Private Sub Worksheet()

Dim i As Long, j As Long, k As Long
Dim count As Long
Dim item As String, temp1 As String, temp2 As String
Dim compare As String
Dim Len_Item As Long
Dim Len_Compare As Long
Dim x As Long
Dim R As Integer, G As Integer, B As Integer

R = 10
G = 40
'B = 140
For i = 2 To Rows.count
Cells(i, 8).Interior.ColorIndex = 6
'Cells(i, 8).Interior.Color = RGB(50, 255, 0)
Next i
x = 3
For i = 2 To Rows.count

If (R < 255) Then
G = G + 15
End If

'B = B + 5

If (G > 255) Then
R = R + 10
G = 40
End If

'count = 0
If (Cells(i, 8).Interior.ColorIndex = 6) Then GoTo Line2 Else i = i + 1


Line2: x = x + 1
temp1 = Cells(i, 8).Value
item = UCase(temp1)

Len_Item = Len(item)

For j = i + 1 To Rows.count - 1
count = 0
temp2 = Cells(j, 8).Value
compare = UCase(temp2)

Len_Compare = Len(compare)

For k = 1 To Len_Item
If (Mid(item, k, 1) = Mid(compare, k, 1)) Then
count = count + 1
End If
Next k

If (count >= 0.75 * Len_Item) Then
If (x < 56) Then
Cells(i, 8).Interior.ColorIndex = x
Cells(j, 8).Interior.ColorIndex = x
'Cells(i, 8).Interior.ColorIndex = RGB(0, 0, 10)
Else
Cells(i, 8).Interior.Color = RGB(R, G, 0)
Cells(j, 8).Interior.Color = RGB(R, G, 0)
End If
End If
Next j
Next i
End Sub

Oh! Thank you for the suggestion.But still the code is very slow and excel is going in not-responding mode

Please find attached some of the manually selected duplicates

Originally Posted by HITESH TAKRANI

Please find attached some of the manually selected duplicates

I have re-written the code please tell me if anything else can be done apart from this to optimize further and make it fast.




Private Sub Worksheet()

Dim i As Long, j As Long, k As Long
Dim count As Long
Dim item As String, temp1 As String, temp2 As String
Dim compare As String
Dim Len_Item As Long
Dim Len_Compare As Long
Dim x As Long
Dim R As Integer, G As Integer, B As Integer

R = 10
G = 40
'B = 140
For i = 2 To 500
Cells(i, 8).Interior.ColorIndex = 3
'Cells(i, 8).Interior.Color = RGB(50, 255, 0)
Next i
x = 3
For i = 2 To 500

If (R < 255) Then
G = G + 15
End If

'B = B + 5

If (G > 255) Then
R = R + 10
G = 40
End If

'count = 0
If (Cells(i, 8).Interior.ColorIndex = 3) Then GoTo Line2 Else GoTo Line5
Line5: i = i + 1
If (Cells(i, 8).Interior.ColorIndex = 3) Then GoTo Line2 Else GoTo Line5
Line2: x = x + 1
temp1 = Cells(i, 8).Value
item = UCase(temp1)

Len_Item = Len(item)

For j = i + 1 To 500
If (Cells(j, 8).Interior.ColorIndex = 3) Then GoTo Line3 Else GoTo Line4
Line4: j = j + 1
If (Cells(j, 8).Interior.ColorIndex = 3) Then GoTo Line3 Else GoTo Line4
Line3: count = 0
temp2 = Cells(j, 8).Value
compare = UCase(temp2)
Len_Compare = Len(compare)

Line3: For k = 1 To Len_Item

If (Mid(item, k, 1) = Mid(compare, k, 1)) Then
count = count + 1
End If
Next k

If (count >= 0.75 * Len_Item) Then
If (x < 56) Then
Cells(i, 8).Interior.ColorIndex = x
Cells(j, 8).Interior.ColorIndex = x
'Cells(i, 8).Interior.ColorIndex = RGB(0, 0, 10)
Else
Cells(i, 8).Interior.Color = RGB(R, G, 0)
Cells(j, 8).Interior.Color = RGB(R, G, 0)
End If
End If
Next j
Next i
End Sub

Is there anything else required TMS?