Limpiar datos automáticamente en Excel (macro)

Option Explicit

Sub LimpiarDatos()
    Dim wsOrigen As Worksheet, wsDestino As Worksheet
    Dim ultimaFila As Long, ultimaCol As Long
    Dim r As Long, i As Long
    Dim c As Range
    Dim cols As Variant
    Dim anyComma As Boolean
    Dim searchRng As Range
    Dim key As String
    Dim dict As Object
    Dim rngToCheck As Range
    Dim arrRow As Variant
    Dim outRow As Long
    Dim headerIsPresent As Boolean
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set wsOrigen = ActiveSheet
    
    On Error Resume Next
    Set wsDestino = Worksheets("Datos_Limpios")
    If Not wsDestino Is Nothing Then wsDestino.Delete
    On Error GoTo 0
    Set wsDestino = Worksheets.Add(After:=wsOrigen)
    wsDestino.Name = "Datos_Limpios"
    
    If wsOrigen.UsedRange Is Nothing Then
        MsgBox "No hay datos en la hoja activa.", vbExclamation
        GoTo Cleanup
    End If
    wsOrigen.UsedRange.Copy
    wsDestino.Range("A1").PasteSpecial xlPasteValues
    Application.CutCopyMode = False
    
    anyComma = False
    Set searchRng = Nothing
    On Error Resume Next
    Set searchRng = wsDestino.Range("A1", wsDestino.Cells(wsDestino.Rows.Count, "A").End(xlUp))
    On Error GoTo 0
    If Not searchRng Is Nothing Then
        For Each c In searchRng
            If InStr(1, CStr(c.Value & ""), ",") > 0 Then
                anyComma = True
                Exit For
            End If
        Next c
    End If
    
    If anyComma Then
        wsDestino.Columns("A:A").TextToColumns Destination:=wsDestino.Range("A1"), _
            DataType:=xlDelimited, Comma:=True, TextQualifier:=xlTextQualifierDoubleQuote
    End If
    
    ultimaFila = wsDestino.Cells(wsDestino.Rows.Count, "A").End(xlUp).Row
    For r = ultimaFila To 1 Step -1
        If Application.WorksheetFunction.CountA(wsDestino.Rows(r)) = 0 Then
            wsDestino.Rows(r).Delete
        End If
    Next r
    
    ultimaFila = wsDestino.Cells(wsDestino.Rows.Count, "A").End(xlUp).Row
    If ultimaFila = 0 Then
        MsgBox "No quedan datos después de eliminar filas vacías.", vbExclamation
        GoTo Cleanup
    End If
    ultimaCol = wsDestino.Cells(1, wsDestino.Columns.Count).End(xlToLeft).Column
    If ultimaCol = 0 Then ultimaCol = 1
    
    For Each c In wsDestino.Range(wsDestino.Cells(1, 1), wsDestino.Cells(ultimaFila, ultimaCol))
        If Not IsError(c.Value) Then
            If Len(CStr(c.Value & "")) > 0 Then
                c.Value = Trim(CStr(c.Value))
            End If
        End If
    Next c
    
    headerIsPresent = False
    For i = 1 To ultimaCol
        If Len(CStr(wsDestino.Cells(1, i).Value & "")) > 0 Then
            If Not IsNumeric(wsDestino.Cells(1, i).Value) Then
                headerIsPresent = True
                Exit For
            End If
        End If
    Next i
    
    If ultimaFila >= 1 And ultimaCol >= 1 Then
        ReDim cols(1 To ultimaCol)
        For i = 1 To ultimaCol
            cols(i) = i
        Next i
        
        On Error Resume Next
        wsDestino.Range(wsDestino.Cells(1, 1), wsDestino.Cells(ultimaFila, ultimaCol)).RemoveDuplicates _
            Columns:=cols, Header:=IIf(headerIsPresent, xlYes, xlNo)
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo ErrHandler
            Set dict = CreateObject("Scripting.Dictionary")
            dict.CompareMode = 1
            
            outRow = 1
            If headerIsPresent Then
                For i = 1 To ultimaCol
                    wsDestino.Cells(outRow, i).Value = wsDestino.Cells(1, i).Value
                Next i
                outRow = outRow + 1
            End If
            
            If headerIsPresent Then
                Set rngToCheck = wsDestino.Range(wsDestino.Cells(2, 1), wsDestino.Cells(ultimaFila, ultimaCol))
            Else
                Set rngToCheck = wsDestino.Range(wsDestino.Cells(1, 1), wsDestino.Cells(ultimaFila, ultimaCol))
            End If
            
            For r = 1 To rngToCheck.Rows.Count
                arrRow = Application.Index(rngToCheck.Value, r, 0)
                key = ""
                For i = LBound(arrRow) To UBound(arrRow)
                    key = key & "|||" & CStr(arrRow(i))
                Next i
                If Not dict.Exists(key) Then
                    dict.Add key, 1
                    For i = 1 To ultimaCol
                        wsDestino.Cells(outRow, i).Value = rngToCheck.Cells(r, i).Value
                    Next i
                    outRow = outRow + 1
                End If
            Next r
            
            If outRow <= ultimaFila Then
                wsDestino.Range(wsDestino.Cells(outRow, 1), wsDestino.Cells(ultimaFila, ultimaCol)).Clear
            End If
            
            Set dict = Nothing
        Else
            On Error GoTo ErrHandler
        End If
    End If
    
    wsDestino.Columns.AutoFit
    wsDestino.Activate
    wsDestino.Range("A1").Select

Cleanup:
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Exit Sub

ErrHandler:
    MsgBox "Error " & Err.Number & " - " & Err.Description & vbCrLf & "Linea aproximada: " & Erl, vbCritical
    Resume Cleanup
End Sub