Excel VBA. coding for large datafiles.

[blizzer]

I have a problem when I'm trying to implement some code for a large excelfile. The purpose of the VBA-code is to delete duplicate cells, row by row. If I start with a sheet looking something like this:

shoe shoe horse
cat horse dog dog
cat cat horse
horse
cat cat
shoe shoe

the I want the result to be:

shoe horse
cat horse dog
cat horse
horse
cat
shoe

My VBA code works but since my real sheet contains over 450 000 rows it takes about 30min to run the code. I hope that one of you could help me see wat I could change in the code to make it faster.

Here is the code:

Option Explicit
'Replace these three constants with maximum number of rows and columns and your Sheet name
'Paste this macro code in the Thisworkbook object in the VB Editor, then run it manually
Private Const MAXROWS = 483184
Private Const MAXCOLS = 50
Private Const SHTNAME = "Sheet1"

Private Sub Remove_Duplicates()
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim x As Long
    Dim y As Long
    Dim colsmax As Long
    Dim delFlag As Boolean
    Dim strTable(MAXCOLS) As String
    Dim delTable(MAXCOLS) As String
    Dim mySheet As Worksheet
    Dim myRange As Range
    Dim strElement As String
    
    colsmax = MAXCOLS
    Set mySheet = ThisWorkbook.Sheets(SHTNAME)
    For i = 1 To MAXROWS
        x = 0
        y = 0
        For j = 1 To colsmax
            delFlag = False
            Set myRange = mySheet.Cells(i, j)
            If x = 0 Then
                strTable(x) = Trim(myRange.Value)
                x = x + 1
            Else
                For k = 1 To x
                    If Trim(myRange.Value) = strTable(k - 1) Then
                        delFlag = True
                        Exit For
                    End If
                Next k
                If delFlag = True Then
                    delTable(y) = CStr(j)
                    y = y + 1

                Else
                    strTable(x) = Trim(myRange.Value)
                    x = x + 1
                End If
            End If
        Next j
        For k = y To 1 Step -1
            j = CLng(delTable(k - 1))
            Set myRange = mySheet.Cells(i, j)
            myRange.Delete (XlDeleteShiftDirection.xlShiftToLeft)
        Next k
    Next i
End Sub

Thanks!

[Siddharth Rout]

Welcome to the forums blizzer :waves:

Try this. Does it still take time?

Sub Sample()
    Dim ws As Worksheet
    Dim aCell As Range
    
    Set ws = Sheet1
    
    With ws
        For Each aCell In ws.Cells.SpecialCells(xlCellTypeConstants, 2)
            aCell.Value = RemDupes(aCell.Value)
        Next
    End With
End Sub

Function RemDupes(sCellVal As String) As String
    Dim TmpArray() As String
    Dim itm As Variant
    
    TmpArray = Split(sCellVal, " ")
    
    For Each itm In TmpArray
        If InStr(RemDupes, Trim(itm)) = 0 Then _
        RemDupes = RemDupes & Trim(itm) & " "
    Next itm
End Function

[blizzer]

Thanks for the reply.
I am completely new to VBA programming so maybe I'm doing something wrong, but when I copied your code and tried to run it with my excelfile nothing seemed to happen.

Should your code be enough for deleting the duplicates row by row?

[Siddharth Rout]

You've to copy the entire code to a module and run the sub sample.

Change this line in respect to the current sheet

Set ws = Sheet1