VBA code to delete row in an Excel table (ListObject) if a specific cell (DataBodyRange) includes a specific substring - excel

Summary. I am trying to loop through a table and delete each row if a particular substring is found in a specified column. I am specifically stuck on the line of code that finds the target text, which I know to be incorrect, but cannot find the proper syntax for what I'm trying to achieve: If tbl.DataBodyRange(rw, 10).Find(myString)
I have searched many websites and YouTube videos, and there are a few that address finding an exact value, but nothing I could find like the problem I'm trying to solve.
My code:
Sub removeTax()
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
Dim myString As String
myString = "Tax"
Dim rw
For rw = tbl.DataBodyRange.Rows.Count To 1 Step -1
If tbl.DataBodyRange(rw, 10).Find(myString) Then
tbl.ListRows.Delete
End If
Next
End Sub
Thank you very much for any assistance you can offer.

Delete Criteria Rows of an Excel Table (ListObject)
As an alternative, this uses a method that uses AutoFilter and SpecialCells.
Usage
Sub RemoveTax()
Const CritColumn As Long = 10
Const CritString As String = "*Tax*" ' contains
Dim tbl As ListObject
Set tbl = ThisWorkbook.Worksheets("Master").ListObjects("tblMaster")
DeleteTableCriteriaRows tbl, CritColumn, CritString
End Sub
The Method
Sub DeleteTableCriteriaRows( _
ByVal Table As ListObject, _
ByVal CriteriaColumn As String, _
ByVal CriteriaString As String)
With Table
If .ShowAutoFilter Then
If .AutoFilter.FilterMode Then .AutoFilter.ShowAllData
Else
.ShowAutoFilter = True
End If
.Range.AutoFilter CriteriaColumn, CriteriaString
Dim rg As Range
On Error Resume Next
Set rg = .DataBodyRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter.ShowAllData
If Not rg Is Nothing Then rg.Delete xlShiftUp
End With
End Sub

I've corrected your approach, it checks if myString is sub-string of values in column 10
With tbl.DataBodyRange.Columns(10)
For rw = .Rows.Count To 1 Step -1
If InStr(1, .Cells(rw).Value2, myString) > 0 Then
tbl.ListRows(rw).Delete
End If
Next rw
End With
Keep in mind, you should check if tbl.DataBodyRange is not Nothing, before doing anything with it, since deleting all rows of a table makes DataBodyRange be equal to Nothing
I've decided to make a bit more efficient solution, more to my liking
Sub RemoveTaxQuicker()
Const myString = "Tax"
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
If tbl.DataBodyRange Is Nothing Then: Exit Sub
Dim rowsRangeString As String
Dim i As Long
Dim C10 As Variant
C10 = tbl.DataBodyRange.Columns(10).Value2
Dim rng As Range
If IsArray(C10) Then
Set rng = Nothing
For i = LBound(C10) To UBound(C10)
If InStr(1, C10(i, 1), myString) > 0 Then
If rng Is Nothing Then
Set rng = tbl.DataBodyRange.Cells(i, 1)
Else
Set rng = Union(rng, tbl.DataBodyRange.Cells(i, 1))
End If
End If
Next i
If Not rng Is Nothing Then
rng.Delete xlUp
End If
ElseIf InStr(1, C10, myString) > 0 Then
tbl.ListRows(1).Delete
End If
End Sub
This is no longer true :) You should use #VBasic2008 approach, I've tested it on 500k rows and it takes around 10 sec or so. And I had to test mine as well (was painfully long), it took ~5 mins. :)
Okay VBasic2008's solution forced me to think about this in a different way. The following solution executes almost instantly.
'works with formulas as well with some exceptions, thanks VBasic for pointing that as a potential problem
Sub RemoveTaxQuicker2()
Const myString = "Tax"
Const COLUMN = 10
Dim tbl As ListObject
Set tbl = ThisWorkbook.Sheets("Master").ListObjects("tblMaster")
If tbl.DataBodyRange Is Nothing Then: Exit Sub
Dim i As Long, j As Long
Dim count As Long
Dim sDataBody As Variant
Dim sFormulas As Variant
sDataBody = tbl.DataBodyRange.Formula
sFormulas = tbl.ListRows(1).Range.Formula
If tbl.DataBodyRange.Rows.count > 1 Then
For i = LBound(sDataBody, 1) To UBound(sDataBody, 1)
If InStr(1, sDataBody(i, COLUMN), myString) < 1 Then
count = count + 1
For j = LBound(sDataBody, 2) To UBound(sDataBody, 2)
sDataBody(count, j) = sDataBody(i, j)
Next j
End If
Next i
If count > 0 Then
For i = LBound(sFormulas, 2) To UBound(sFormulas, 2)
If Left$(sFormulas(1, i), 1) = "=" Then
sDataBody(1, i) = sFormulas(1, i)
End If
Next i
tbl.DataBodyRange.Formula = sDataBody
If tbl.ListRows.count > count Then
tbl.ListRows(count + 1).Range.Resize(tbl.ListRows.count).ClearContents
tbl.Resize tbl.Range.Resize(count + 1)
End If
End If
ElseIf InStr(1, sDataBody(1, COLUMN), myString) > 0 Then
On Error Resume Next
tbl.DataBodyRange.SpecialCells(xlCellTypeConstants).ClearContents
On Error GoTo 0
End If
End Sub
Final note: I still prefer VBasic's method, if nothing else it's much cleaner and it works when the table is full of formulas that are not auto-filled :)

Related

How to select and copy the first 5 rows from a table after applying filters

I would like to copy the first 5 rows (to cell M7) after applying a filter in the table. I have tried a macro found on the internet, but it does not work in any way in my file.
Sub TopNRows()
Dim i As Long
Dim r As Range
Dim rWC As Range
Set r = Range("B16", Range("B" & Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible)
For Each rWC In r
i = i + 1
If i = 5 Or i = r.Count Then Exit For
Next rWC
Range(r(2), rWC).Resize(, 7).SpecialCells(xlCellTypeVisible).Copy Sheet7.[M7]
End Sub
I tried to customize them, where my table has x rows (I operate dynamically) and 7 columns. The headings are in (B15:H15). However, they do not work all the time. The error pops up for me at
Range(r(2), rWC).Resize(, 7).SpecialCells(xlCellTypeVisible).Copy Sheet7.[M7]
Try the following...
Sub TopNRows()
Dim rng As Range
Dim filt As Range
Dim topRows As Range
Dim currentCell As Range
Dim count As Long
Set rng = Range("B15", Range("B" & Rows.count).End(xlUp))
With rng
On Error Resume Next
Set filt = .Offset(1, 0).Resize(.Rows.count - 1).SpecialCells(xlCellTypeVisible)
If filt Is Nothing Then
MsgBox "No records found!", vbExclamation
Exit Sub
End If
On Error GoTo 0
End With
count = 0
For Each currentCell In filt.Cells
If topRows Is Nothing Then
Set topRows = currentCell
Else
Set topRows = Union(topRows, currentCell)
End If
count = count + 1
If count >= 5 Then Exit For
Next currentCell
topRows.Copy Sheet7.[M7]
End Sub

Unable to search and replace the values using column headers

I'm trying to create a vba script that will search for the _ in all the cells fallen under Crude Items column. However, when it finds one, it will split the values from _ and place the rest in corresponding cells fallen under Refined Ones column.
I've tried with the following which is doing the job flawlessly but I wish to search and replace the values using column headers:
Sub CopyAndReplace()
Dim cel As Range
For Each cel In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).row)
If cel.value <> "" Then
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
End If
Next cel
End Sub
To let you visualize how the sheet might look like:
How can I search and replace the values using column headers?
I am not sure this is what you are after, but a few important mentions...
Try to always use at least a worksheet qualifier when writing your code. How else is your program going to know explicitly where you would like it to operate?
I have changed your process slightly, but again, not sure if this is exactly what you are after. See below code.
Sub SplitByHeader()
Dim i As Long
Dim crudeHeader As Range, refinedHeader As Range
Dim ws As Worksheet
'set ws
Set ws = ThisWorkbook.Sheets("Sheet1")
'set header ranges
Set crudeHeader = ws.Rows(1).Find(What:="Crude Items", LookAt:=xlWhole)
Set refinedHeader = ws.Rows(1).Find(What:="Refined Ones", LookAt:=xlWhole)
'simple error handler
If crudeHeader Is Nothing Or refinedHeader Is Nothing Then Exit Sub
For i = 2 To ws.Cells(ws.Rows.Count, crudeHeader.Column).End(xlUp).Row
If ws.Cells(i, crudeHeader.Column).Value <> "" Then
ws.Cells(i, refinedHeader.Column).Value = Split(ws.Cells(i, crudeHeader.Column).Value, "_")(1)
End If
Next i
End Sub
I have just tried this one with the code below:
It is a good idea to add additional check to the condition, like this - If myCell.Value <> "" And InStr(1, myCell, "_") Then to avoid starting from A2.
The idea is that the LocateValueCol locates the column of the first row, which has the string, passed to it. Knowing this, it works ok.
Option Explicit
Sub CopyAndReplace()
Dim searchColumn As Long
searchColumn = LocateValueCol("SearchCol", Worksheets(1))
Dim replaceColumn As Long
replaceColumn = LocateValueCol("ReplaceCol", Worksheets(1))
Dim myCell As Range
Dim lastCell As Long
With Worksheets(1)
lastCell = .Cells(.Rows.Count, searchColumn).End(xlUp).Row
For Each myCell In .Range(.Cells(1, searchColumn), .Cells(lastCell, searchColumn))
If myCell.Value <> "" And InStr(1, myCell, "_") Then
.Cells(myCell.Row, replaceColumn) = Split(myCell, "_")(1)
End If
Next
End With
End Sub
This is the function, locating the columns. (If you have ideas for improvement, feel free to make a PR here):
Public Function LocateValueCol(ByVal textTarget As String, _
ByRef wksTarget As Worksheet, _
Optional rowNeeded As Long = 1, _
Optional moreValuesFound As Long = 1, _
Optional lookForPart = False, _
Optional lookUpToBottom = True) As Long
Dim valuesFound As Long
Dim localRange As Range
Dim myCell As Range
LocateValueCol = -999
valuesFound = moreValuesFound
Set localRange = wksTarget.Range(wksTarget.Cells(rowNeeded, 1), wksTarget.Cells(rowNeeded, Columns.Count))
For Each myCell In localRange
If lookForPart Then
If textTarget = Left(myCell, Len(textTarget)) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
Else
If textTarget = Trim(myCell) Then
If valuesFound = 1 Then
LocateValueCol = myCell.Column
If lookUpToBottom Then Exit Function
Else
Decrement valuesFound
End If
End If
End If
Next myCell
End Function
Private Sub Increment(ByRef valueToIncrement As Variant, Optional incrementWith As Double = 1)
valueToIncrement = valueToIncrement + incrementWith
End Sub
Private Sub Decrement(ByRef valueToDecrement As Variant, Optional decrementWith As Double = 1)
valueToDecrement = valueToDecrement - decrementWith
End Sub
For fun using regex and dynamically finding header columns. You can swop out the regex based function for your own and still have the dynamic column finding.
Option Explicit
Public Sub test()
Dim i As Long, inputs(), re As Object, ws As Worksheet
Dim inputColumn As Range, outputColumn As Range, inputColumnNumber As Long, outputColumnNumber As Long
Const SEARCH_ROW As Long = 1
Const INPUT_HEADER As String = "Crude items"
Const OUTPUT_HEADER As String = "Refined Ones"
Const START_ROW = 2
Set re = CreateObject("VBScript.RegExp")
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set inputColumn = GetColumnByHeader(ws, SEARCH_ROW, INPUT_HEADER)
Set outputColumn = GetColumnByHeader(ws, SEARCH_ROW, OUTPUT_HEADER)
If inputColumn Is Nothing Or outputColumn Is Nothing Then Exit Sub
inputColumnNumber = inputColumn.Column
outputColumnNumber = outputColumn.Column
With ws
inputs = Application.Transpose(.Range(.Cells(START_ROW, inputColumnNumber), .Cells(.Cells(.Rows.Count, inputColumnNumber).End(xlUp).Row, inputColumnNumber)).Value)
For i = LBound(inputs) To UBound(inputs)
inputs(i) = GetMatch(re, inputs(i))
Next
.Cells(START_ROW, outputColumnNumber).Resize(UBound(inputs), 1) = Application.Transpose(inputs)
End With
End Sub
Public Function GetColumnByHeader(ByVal ws As Worksheet, ByVal SEARCH_ROW As Long, ByVal columnName As String) As Range
Set GetColumnByHeader = ws.Rows(SEARCH_ROW).Find(columnName)
End Function
Public Function GetMatch(ByVal re As Object, ByVal inputString As String) As String
With re
.Global = True
.MultiLine = True
.Pattern = "_(.*)"
If .test(inputString) Then
GetMatch = .Execute(inputString)(0).SubMatches(0)
Else
GetMatch = inputString 'or =vbNullString if want to return nothing
End If
End With
End Function
If you are working through an actual table things will become quite easy:
Sub Test()
Dim arr(), x As Long
With ThisWorkbook.Sheets("Sheet1") 'Change accordingly
For Each cl In .Range("Table1[Crude Items]") 'Change Table1 accordingly
ReDim Preserve arr(x)
If InStr(cl, "_") > 0 Then
arr(x) = Split(cl, "_")(1)
Else
arr(x) = ""
End If
x = x + 1
Next cl
.Range("Table1[Refined Ones]").Value = Application.Transpose(arr)
End With
End Sub
There is a check for "_". If not there, the cell will be kept empty.
You can also consider to use formula to do it.
I am not clear about what you want to replace "_" character with. For example, iff you replace the following line of your script:
Sheets("Sheet1").Range(cel(1, 3).Address) = Split(cel, "_")(1)
with this one:
Sheets("Sheet1").Range(cel(1, 3).Address) = WorksheetFunction.Substitute(cel, "_", "")
The above line should replace the "_" character with nothing from the cells in the Crude_Items column
And as Lee said, you can also consider using formula in the worksheet if you do not have significant amount of data

Check wether a set of data already exists in current worksheet

I have a large table filled with data. What I want to do is check wether a set of data already exists within this table. I have inserted the data I am looking for in a separate worksheet. The Range with the table items I am looking for I called "SearchedData" and the Area where I am checking wether it holds the data I am looking for I called "SearchArea".
My code only shows me the data would exist but in the worksheet I am working on it doesn't so there must be something wrong with my code. Any help on this would be very much appreciated!
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
SearchArea = ThisWorkbook.Worksheets("Tabelle1").Range("A:E").Value
If SearchArea = SearchedData Then
MsgBox ("Searched Data already exists")
Else: MsgBox ("Searched Data is missing")
End If
End Sub
This is a way more complicated to solve.
Imagine Tabelle2 as following:
And Tabelle1 as following:
I suggest to use the Range.Find method to find the first occurenc of the first cells data here this is represented by 11. And then check if the rest of the data is right/below there too. Do this in a loop until all occurences are checked.
So in Tabelle1 the yellow areas will be ckecked but the only full match is at A14:E17 which will be considered as duplicate.
Option Explicit
Public Sub CheckIfDataExists()
Dim wsSearch As Worksheet
Set wsSearch = ThisWorkbook.Worksheets("Tabelle1")
Dim SearchRange As Range
Set SearchRange = wsSearch.Range("A1", wsSearch.Cells(wsSearch.Rows.Count, "A").End(xlUp))
Dim SearchData() As Variant 'data array
SearchData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
Dim FoundData() As Variant
'remember first find to prevent endless loop
Dim FirstFoundAt As Range
Set FirstFoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=SearchRange.Cells(1, 1), LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FirstFoundAt Is Nothing Then
Dim FoundAt As Range
Set FoundAt = FirstFoundAt
Do
Set FoundAt = SearchRange.Find(What:=SearchData(1, 1), After:=FoundAt, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not FoundAt Is Nothing Then
FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Select
FoundData = FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Value
If AreArraysEqual(SearchData, FoundData) Then
MsgBox "data found at " & FoundAt.Resize(UBound(SearchData, 1), UBound(SearchData, 2)).Address
Exit Sub
End If
End If
Loop Until FoundAt Is Nothing Or FirstFoundAt.Row >= FoundAt.Row
End If
MsgBox "data not found"
End Sub
Private Function AreArraysEqual(Arr1 As Variant, Arr2 As Variant) As Boolean
Dim iRow As Long, iCol As Long
'default
AreArraysEqual = True
For iRow = LBound(Arr1, 1) To UBound(Arr1, 1)
For iCol = LBound(Arr1, 2) To UBound(Arr1, 2)
If Arr1(iRow, iCol) <> Arr2(iRow, iCol) Then
AreArraysEqual = False
Exit Function
End If
Next iCol
Next iRow
End Function
I believe this code will do what you want reasonably fast.
Sub CheckWetherDataExists()
Dim SearchedData As Variant
Dim SearchArea As Variant
Dim LookFor() As String
Dim LookIn() As String
Dim R As Long, C As Long
SearchedData = ThisWorkbook.Worksheets("Tabelle2").Range("C5:G8").Value
LookFor = MergedRows(SearchedData)
With ThisWorkbook.Worksheets("Tabelle1")
SearchArea = .Range(.Cells(2, 1), .Cells(.Rows.Count, 5).End(xlUp)).Value
End With
LookIn = MergedRows(SearchArea)
For R = 1 To UBound(LookIn)
If LookIn(R) = LookFor(1) Then
If R < UBound(LookIn) - 2 Then
For C = 2 To UBound(LookFor)
If LookIn(R + C - 1) <> LookFor(C) Then Exit For
Next C
If C > UBound(LookFor) Then
MsgBox "Match found in Row " & R
Exit For
End If
End If
End If
Next R
End Sub
Private Function MergedRows(RngVal As Variant) As String()
Dim Fun() As String
Dim R As Long, C As Long
ReDim Fun(1 To UBound(RngVal))
For R = 1 To UBound(RngVal)
For C = 1 To UBound(RngVal, 2)
Fun(R) = Fun(R) & "," & RngVal(R, C)
Next C
Next R
MergedRows = Fun
End Function
The code creates merged strings of 5 cells of both the SearchedData and the SearchArea data. This job is done by the Function MergedRows. In the process the SearchedData turn into array LookFor(1 To 3) and LookIn(1 To LastRow). Next the first element (representing a row) of LookFor is compared to each element (representing a row) of LookIn. If a match is found the other two rows are also compared. When all three elements (rows) match a message is issued and the search is terminated.

Running Macro Once Does Not Do Anything. Running the Macro Again Works

I'm having some trouble with a macro I've been working on. It's used to delete blanks (over a million blank rows) when another separate macro is run. If I get this one working, I would like to merge the two macros together.
Here is the macro:
Sub Test()
DeleteBlankTableRows ActiveSheet.ListObjects(1)
End Sub
Sub DeleteBlankTableRows(ByVal tbl As ListObject)
Dim rng As Range
Set rng = tbl.DataBodyRange ' Get table data rows range.
Dim DirArray As Variant
DirArray = rng.Value2 ' Save table values to array.
' LOOP THROUGH ARRAY OF TABLE VALUES
Dim rowTMP As Long
Dim colTMP As Long
Dim combinedTMP As String
Dim rangeToDelete As Range
' Loop through rows.
For rowTMP = LBound(DirArray) To UBound(DirArray)
combinedTMP = vbNullString ' Clear temp variable.
' Loop through each cell in the row and get all values combined.
For colTMP = 1 To tbl.DataBodyRange.Columns.Count
combinedTMP = combinedTMP & DirArray(rowTMP, colTMP)
Next colTMP
' Check if row is blank.
If combinedTMP = vbNullString Then
' Row is blank. Add this blank row to the range-to-delete.
If rangeToDelete Is Nothing Then
Set rangeToDelete = tbl.ListRows(rowTMP).Range
Else
Set rangeToDelete = Union(rangeToDelete, tbl.ListRows(rowTMP).Range)
End If
End If
Next rowTMP
' DELETE BLANK TABLE ROWS (if any)
If Not rangeToDelete Is Nothing Then rangeToDelete.Delete
End Sub
First time it is run, it loads and acts like it's going to work. Less than a minute after loading...nothing happens (at least, visually). I run it again and it loads quickly; this time, the blank rows are visually gone.
A similar idea using an explicit parent sheet reference and Index and Max to determine if a row is blank.
Option Explicit
Public Sub DeleteRowsIfBlank()
Dim ws As Worksheet, table As ListObject, arr(), i As Long, counter As Long, unionRng As Range
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set table = ws.ListObjects(1)
arr = table.DataBodyRange.Value
counter = table.DataBodyRange.Cells(1, 1).Row
For i = LBound(arr, 1) To UBound(arr, 1)
If Application.Max(Application.Index(arr, i, 0)) = 0 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, table.Range.Rows(counter))
Else
Set unionRng = table.Range.Rows(counter)
End If
End If
counter = counter + 1
Next
If Not unionRng Is Nothing Then unionRng.Delete
End Sub

Extract unique distinct list from two columns

So I am trying to create a combined list from two separate columns by omitting the duplicate items. I have searched and found a formula that combines the list this way by going through one column at a time.
But I want to combine the columns like this:
where it goes through each row first.
Is there a formula or VBA code that does that? Thank you.
EDIT: This is just a way to show my request. The color was added to show how the combined list is sorted, it is not part of the request. The actual lists are each about 500 rows long consisting of 9+ digit ID numbers.
This will put the unique words in the order you want.
Sub foo()
Dim rng As Range
Dim ws As Worksheet
Dim i&, j&, t&
Dim dict As Object
Dim iArr() As Variant
Dim oarr() As Variant
Dim itm As Variant
Set dict = CreateObject("Scripting.Dictionary")
Set ws = ActiveSheet
With ws
Set rng = .Range("A:B").Find("*", .Range("A1"), , , , xlPrevious)
If Not rng Is Nothing Then
iArr = .Range(.Cells(2, 1), .Cells(rng.Row, 2)).Value
For i = LBound(iArr, 1) To UBound(iArr, 1)
For j = LBound(iArr, 2) To UBound(iArr, 2)
If iArr(i, j) <> "" Then
On Error Resume Next
dict.Add iArr(i, j), iArr(i, j)
On Error GoTo 0
End If
Next j
Next i
End If
'If your dataset is not that large <30,000, then you can use it directly with transpose
.Range("C2").Resize(dict.Count) = Application.Transpose(dict.items)
'If your data is large then you will want to put it in a one dimensional array first
'just uncomment the below and comment the one line above
' ReDim oarr(1 To dict.Count, 1 To 1)
' t = 1
' For Each itm In dict.keys
' oarr(t, 1) = dict(itm)
' t = t + 1
' Next itm
' Range("C2").Resize(dict.Count) = oarr
End With
End Sub
UDF solution. Using your provided sample data, put this formula in cell I2 and copy down =UnqList(ROW(I1),$G$2:$H$6) or =UnqList(ROW(I1),$G$2:$G$6,$H$2:$H$6) (it can be either because the two or more lists might not be next to each other and the UDF accounts for that)
Public Function UnqList(ByVal lIndex As Long, ParamArray rLists() As Variant) As Variant
Dim i As Long, j As Long
Dim vList As Variant
Dim cUnq As Collection
Dim lMaxRow As Long, lMaxCol As Long
If lIndex <= 0 Then
UnqList = CVErr(xlErrRef)
Exit Function
End If
For Each vList In rLists
If TypeName(vList) <> "Range" Then
UnqList = CVErr(xlErrRef)
Exit Function
Else
If vList.Rows.Count > lMaxRow Then lMaxRow = vList.Rows.Count
If vList.Columns.Count > lMaxCol Then lMaxCol = vList.Columns.Count
End If
Next vList
Set cUnq = New Collection
For i = 1 To lMaxRow
For j = 1 To lMaxCol
For Each vList In rLists
If i <= vList.Rows.Count And j <= vList.Columns.Count Then
On Error Resume Next
cUnq.Add vList.Cells(i, j).Value, CStr(vList.Cells(i, j).Value)
On Error GoTo 0
If lIndex = cUnq.Count Then
UnqList = cUnq(cUnq.Count)
Set cUnq = Nothing
Exit Function
End If
End If
Next vList
Next j
Next i
UnqList = CVErr(xlErrRef)
Set cUnq = Nothing
End Function
You can use my Duplicate Master addin available via my profile.
Advantages are that the addin provides options to
ignore capitilisation
ignore whitespace
run RegExp replacements (advanced)
further options for deletinf, highlighting, selecting duplicates etc

Resources