Hi,
This is another code with the same style as above and similar to it,
this time it highlights instead of delete duplicate values...
I am wondering why these two codes take seconds to execute on about
2000 rows when the Excel delete duplicates takes milliseconds... The
code for highlighting is not equivalent to the Excel function. I
understand highlighting duplicates values goes from top to bottom, it
highlights EVERY duplicates values in a column, it's not taking in
consideration duplicate rows... when the remove duplicate function
delete duplicate rows...
To sum up, I'm wondering why these code take quite some time? What is
the "Remove duplicate" function made with? I understand if I use it in
the code in the first post (I would need more knowledge of Excel
objects, methods, properties I don't have yet) it would avoid the use
of looping through the entire data but doing this with an array in
memory shouldn't take so long???
Option Explicit
Dim TableA() As Variant
Dim TableB() As Long
Sub HighliteDuplicateValues()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ThisWorkbook
Dim ws As Worksheet
Set ws = wb.Worksheets(1)
Dim wsLastRow As Long, wsLastCol As Long 'worksheet base 1 array
Dim bigStr As String
ReDim TableA(0, 0)
Dim TaLastR As Long, TaLastC As Long
ReDim TableB(0)
Dim TbLastR As Long, TbLastC As Long
TbLastR = 0
Dim i As Long, j As Long
Dim it As Long, jt As Long
Dim tmp As Long
Dim x As Variant
Dim markValue As String
markValue = "---%%%"
'Copy all values into TableA
'Add one more column in TableA to concatenate rows values
wsLastRow = ws.Range("A1").CurrentRegion.Rows.Count
wsLastCol = ws.Cells(1, Columns.Count).End(xlToLeft).Column
TaLastR = wsLastRow - 2
TaLastC = wsLastCol
ReDim TableA(TaLastR, TaLastC)
For i = 0 To TaLastR
For j = 0 To TaLastC
TableA(i, j) = ws.Cells(i + 2, j + 1).Value
Next j
For jt = 1 To TaLastC
bigStr = CStr(bigStr) & CStr(ws.Cells(i + 2, jt))
Next jt
TableA(i, j - 1) = CStr(bigStr)
bigStr = ""
Next i
'Count duplicate values from concatenation
'Set the tableB dimensions from counting duplicates
'Copy row numbers of duplicate values into new table
ReDim Preserve TableA(TaLastR, TaLastC + 1)
ReDim TableB(TbLastR + 2)
For i = 0 To TaLastR - 1
If CStr(TableA(i, TaLastC + 1)) = "" Then
For j = 0 To TaLastR
If i <> j Then
If CStr(TableA(i, TaLastC)) = CStr(TableA(j, TaLastC))
Then
TableA(i, TaLastC + 1) = markValue
TableA(j, TaLastC + 1) = markValue
TableB(TbLastR) = i + 2
TableB(TbLastR + 1) = j + 2
TbLastR = TbLastR + 2
ReDim Preserve TableB(TbLastR + 1)
End If
End If
Next j
End If
Next i
ReDim Preserve TableB(TbLastR - 1)
'''Test 1 : Mark duplicates on worksheets for comparaison and counting
For i = 0 To TaLastR
If CStr(TableA(i, TaLastC + 1)) = markValue Then
ws.Cells(i + 2, 3) = TableA(i, TaLastC + 1)
End If
Next i
ws.Range("A1").Select
'Highlight values in worksheet based on row numbers in new table
'Function to sort
x = SortArray(TableB)
'Apply color on duplicate
For i = 0 To TbLastR - 1
tmp = TableB(i)
ws.Cells(tmp, 1).Interior.Color = 65535
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Function SortArray(ByRef Table() As Long) As Variant
Dim tmp As Long
Dim i As Long, j As Long
For i = 0 To UBound(Table) - 1
For j = i + 1 To UBound(Table) - 1
If Table(i) > Table(j) Then
tmp = Table(i)
Table(i) = Table(j)
Table(j) = tmp
End If
Next j
Next i
SortArray = Table()
End Function
--
----------------------------------------------------------------------------------
Some important links for excel users:
1. Follow us on TWITTER for tips tricks and links :
http://twitter.com/exceldailytip
2. Join our LinkedIN group @ http://www.linkedin.com/groups?gid=1871310
3. Excel tutorials at http://www.excel-macros.blogspot.com
4. Learn VBA Macros at http://www.quickvba.blogspot.com
5. Excel Tips and Tricks at http://exceldailytip.blogspot.com
To post to this group, send email to excel-macros@googlegroups.com
<><><><><><><><><><><><><><><><><><><><><><>
Like our page on facebook , Just follow below link
http://www.facebook.com/discussexcel
