Option Explicit
Option Base 1
Sub tst1()
Dim tRng As Range
Set tRng = getDupRng1(Range("a1:a100000"))
End Sub
Public Function getDupRng1(inRng As Range) As Range
Dim tArea As Range
Dim tArr As Variant, TMP As Variant, pVal As Variant
Dim numRows As Long, i As Long, j As Long, totCnt As Long, frCnt As Long
Dim vDic As Object
Dim totAdd() As String, frAdd() As String
Dim stCell As Range
Dim consecRng As Boolean
Dim tStr As String, lstAdd As String
Dim tim As Double
tim = Timer
If inRng Is Nothing Then Exit Function
Set vDic = CreateObject("scripting.dictionary")
'set initial arrays to max possible size
ReDim totAdd(1 To inRng.Cells.Count)
ReDim frAdd(1 To inRng.Cells.Count)
'loop through all areas
For Each tArea In inRng.Areas
'sets temp array, number of rows, and the first cell in range
tArr = tArea.Value2
numRows = UBound(tArr)
Set stCell = tArea.Cells(1)
'loops through each cell, column outside rows in loop -- usually more rows than cols
With stCell
For i = 1 To UBound(tArr, 2)
For j = 1 To numRows
'set a tmp var to the cell value (not much faster, easier to read)
TMP = tArr(j, i)
'check if empty, skips if is
If TMP <> Empty Then
'this improves speed on sorted or semisorted data
If TMP <> pVal Then
pVal = TMP
'checks if exists, if does, adds, if not adds to "other" array
If Not vDic.exists(TMP) Then
vDic.Add TMP, .Offset(j - 1, i - 1).Address
'new unique so dup range is broken
consecRng = False
Else
If consecRng Then
'this just returns the current last address of the consecutive range
lstAdd = .Offset(j - 1, i - 1).Address
Else
'here consec is broken so check to add
If lstAdd <> vbNullString Then
totAdd(totCnt) = totAdd(totCnt) & ":" & lstAdd
lstAdd = vbNullString
End If
'start new range
totCnt = totCnt + 1
totAdd(totCnt) = .Offset(j - 1, i - 1).Address
consecRng = True
End If
'if unique first then add to frAdd
If vDic.Item(TMP) <> Empty Then
frCnt = frCnt + 1
frAdd(frCnt) = vDic.Item(TMP)
vDic.Item(TMP) = Empty
End If
End If
Else
'same as above just skip dictionary bit
If consecRng Then
lstAdd = .Offset(j - 1, i - 1).Address
Else
If lstAdd <> vbNullString Then
totAdd(totCnt) = totAdd(totCnt) & ":" & lstAdd
lstAdd = vbNullString
End If
totCnt = totCnt + 1
totAdd(totCnt) = .Offset(j - 1, i - 1).Address
consecRng = True
End If
If vDic.Item(TMP) <> Empty Then
frCnt = frCnt + 1
frAdd(frCnt) = vDic.Item(TMP)
vDic.Item(TMP) = Empty
End If
End If
End If
Next j
'gets last one if possible
If consecRng Then
If lstAdd <> vbNullString Then totAdd(totCnt) = totAdd(totCnt) & ":" & lstAdd
End If
'havent really tested multiple columns this would restart consec though
consecRng = False
Next i
End With
Next tArea
'redimensions lists
ReDim Preserve totAdd(1 To totCnt)
ReDim Preserve frAdd(1 To frCnt)
'this gets the total range...very slow (dont run if str array>10000)
If totCnt > 10000 Or frCnt > 10000 Then
MsgBox "will take long to run...over a minute"
Stop
End If
Set getDupRng1 = strUnion(frAdd)
getDupRng1.Interior.ColorIndex = 4
Set getDupRng1 = strUnion(totAdd)
getDupRng1.Interior.ColorIndex = 3
MsgBox Timer - tim
End Function
Public Function strUnion(strArr() As String, Optional stRng As Range = Nothing, Optional pWs As Worksheet) As Range
Dim i As Long
Dim tStr As String
Dim doUnion As Boolean
If pWs Is Nothing Then Set pWs = ActiveSheet
If Not stRng Is Nothing Then
Set strUnion = stRng
doUnion = True
End If
For i = LBound(strArr) To UBound(strArr)
If strArr(i) <> vbNullString Then
If Len(tStr) + Len(strArr(i)) > 254 Then
If doUnion Then
Set strUnion = Union(strUnion, pWs.Range(tStr))
Else
Set strUnion = pWs.Range(tStr)
doUnion = True
End If
tStr = strArr(i)
Else
If tStr <> vbNullString Then
tStr = tStr & "," & strArr(i)
Else: tStr = strArr(i)
End If
End If
End If
Next i
If doUnion Then
Set strUnion = Union(strUnion, pWs.Range(tStr))
Else
Set strUnion = pWs.Range(tStr)
End If
End Function
