How to create a function that returns an range - excel

I am looking to create a function that will take 2 ranges (of the same dimensions), and take the difference between the cell from one range and the corresponding cell in the other range, and then create a new range with all of the differences. Are there any obvious problems? If i select and crtl + sht + enter, the range fills with "#Value!"
This is what i have so far (assuming the ranges are 4 by 4s):
Function Compare_Ranges(range_1 As Range, range_2 As Range) As Range
Dim output_data As Range
Dim i As Integer
Dim j As Integer
Dim col As String
For i = 1 To 4 'looping through the columns
col = Col_Letter(i)
For j = 1 To 4 'looping through the rows
Set output_data(Col_Letter(i) & j) = range_1(Col_Letter(i) & j).Value - range_2(Col_Letter(i) & j).Value
Next j
Next i
Compare_Ranges = output_data
End Function
Where the function Col_Letter returns the correponding letter of the alphabet:
Function Col_Letter(lngCol As Integer) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function

Here is a version of your function that takes two ranges of the same size and returns an array with the same dimensions that holds the difference between each corresponding cell in the input ranges.
Function Compare_Ranges(range_1 As Range, range_2 As Range) As Variant
Dim output_data() As Variant
Dim c As Integer
Dim r As Integer
ReDim output_data(1 To range_1.Rows.Count, 1 To range_1.Columns.Count)
For c = 1 To UBound(output_data, 2) 'looping through the columns
For r = 1 To UBound(output_data, 1) 'looping through the rows
output_data(r, c) = range_1.Cells(r, c).Value - range_2.Cells(r, c).Value
Next
Next
Compare_Ranges = output_data
End Function
If you want to put this in a cell, you will need to press CTRL+ENTER after entiering the following in a cell:
=Compare_Ranges(A1:A7,B1:B7)
The function returns an array, so if you want to catch it's results by calling it in another sub procedure, you need the following"
Dim data as variant
data = Compare_Ranges(range("a1:a7"),range("b1:b7"))

I am not sure if I got this right but I hope at least will help you to get there. The function takes any two ranges and calculate the difference between them and store the result into an array.
Function Compare_Ranges(range_1 As Range, range_2 As Range, ByVal y As Long) As Variant
Dim j As Long
Dim col As String
Dim one As Object, two As Object, three As Variant
Set one = CreateObject("Scripting.Dictionary")
Set two = CreateObject("Scripting.Dictionary")
j = 0
For Each cell In range_1
one.Add Key:=j, Item:=cell.Value
j = j + 1
Next
j = 0
For Each cell In range_2
two.Add j, cell.Value
j = j + 1
Next
ReDim three(0 To j) As Variant
For i = 0 To j
three(i) = one(i) - two(i)
Next
Compare_Ranges = three(y)
End Function
Then you can use the code in the sub to populate them in any range you like.
Sub result()
Dim one As Range, two As Range, three As Range
Dim j As Long
Set one = Worksheets("Sheet1").Range("A1:A4")
Set two = Worksheets("Sheet1").Range("B1:B4")
Set result = Worksheets("Sheet1").Range("D8:D11")
j = 0
For i = three.Row To ((result.Row + result.Rows.Count) - 1)
Worksheets("Sheet1").Cells(i, result.Column) = Compare_Ranges(one, two, j)
j = j + 1
Next
End Sub

Related

how to find highest and lowest value based on a specific range in Excel VBA?

I got this code from several references to find the highest and lowest scores:
Then there is something that makes me curious, How do I implement this code in a certain range where I have thousands of data?
Example:
The code is run when I want to find the 10 or 30 highest data values in the range B2: B4000 contained in Sheet1, and put the results in sheet 1, range C2?
Function Max(ParamArray values() As Variant) As Variant
Dim maxValue, Value As Variant
maxValue = values(0)
For Each Value In values
If Value > maxValue Then maxValue = Value
Next
Max = maxValue
End Function
Function Min(ParamArray values() As Variant) As Variant
Dim minValue, Value As Variant
minValue = values(0)
For Each Value In values
If Value < minValue Then minValue = Value
Next
Min = minValue
End Function
Try the next code, please:
Sub LargestInRange_array()
Dim sh As Worksheet, arr, nrR As Long, i As Long
Set sh = ActiveSheet 'use here the sheet you need
arr = sh.Range("B2:B4000").Value 'put the range in an array
nrR = 5 'the number of Top to be returned (that 10 to 30, in your question)
'clear the previous returned Top:
sh.Range("C2:C" & sh.Range("C" & sh.rows.count).End(xlUp).row).ClearContents
For i = 1 To nrR
sh.Range("C" & i + 1).Value = WorksheetFunction.Large(arr, i)
Next i
End Sub
It places as many largest values you set in the variable nrR, starting from "C2".
Edited:
Please, try the version using a function and needing only a range and the Top number. It determines which is the last row in the column to be processed:
Sub testTopXSales()
Dim sh As Worksheet, rng As Range, arrTop, lastR
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last row in the range to be processed
'adapt "B" to the column you use
Set rng = sh.Range("B2:B" & lastR) 'use here the range to be processed
rng.Offset(0, 1).EntireColumn.ClearContents 'clear the clumn to the right contents
arrTop = TopXSales(rng, 10) 'defining the Top array, using the function
'drop the array content in the next column:
rng.Offset(0, 1).Resize(UBound(arrTop) + 1, 1).Value = Application.Transpose(arrTop)
End Sub
Function TopXSales(rng As Range, TopNr As Long) As Variant
Dim arr, arrTop, i As Long, k As Long
ReDim arrTop(TopNr - 1) 'redim the array to keep the largest value (- 1 because it is a 1D array starting from 0)
arr = rng.Value 'put the range in an array. It will work with the range itself, but it should be faster so
For i = 0 To TopNr - 1 'creating the Top array
arrTop(k) = WorksheetFunction.Large(arr, i + 1): k = k + 1
Next i
TopXSales = arrTop 'make the function to return the Top array
End Function
Hy maybe it will help you out
Private Sub hy()
Dim foo As Object
Set foo = test(3)
Dim i As Integer
For i = 0 To foo.count - 1
Debug.Print foo(i)
Next i
End Sub
Function test(count As Integer) As Object
Dim arr As Object
Set arr = CreateObject("System.Collections.ArrayList")
arr.Add 70
arr.Add 30
arr.Add 60
arr.Add 50
arr.Add 200
arr.Add 10
arr.Sort
Set test = CreateObject("System.Collections.ArrayList")
Dim i As Integer
For i = arr.count - 1 To arr.count - count Step -1
test.Add arr(i)
Next i
End Function

Passing multiple arguments to a function to check duplicate values from an array

I am trying to count duplicate values from a column range using an array, I created a function that takes 3 arguments, number of rows and 2 strings (Long,String,String) for the comparison. I noticed that it only detects duplicates whenever values are next to each other. I already tried looping from 1 to the last row to make sure that each value will be compared to the rest but I got subscript out of range error.
Here's my code:
Sub CountByErrorTest()
Dim rangeArr() As Variant
Dim tester2 As Worksheet
Set tester2 = Worksheets("tester2")
Dim i As Long, j As Long, lrow As Long
lrow = 3169
rangeArr = Worksheets("tester").Range("a2").Resize(lrow, 29).Value2
For i = 1 To 29
For j = 1 To lrow - 1
If dupVal((rangeArr(j, i)), ((rangeArr(j + 1, i)))) Then
tester2.Range("g4") = tester2.Range("g4") + 1
End If
Next j
Next i
End Sub
My function:
Function dupVal(s1 As String, s2 As String) As Boolean
Dim i As Long
If s1 = s2 Then
dupVal = True
Exit Function
End If
dupVal = False
End Function
I tried looping it like this: Gets out of range error
For k = 1 To lrow - 1
If dupVal((rangeArr(j, i)), ((rangeArr(j + k, i)))) Then
tester2.Range("g4") = tester2.Range("g4") + 1
End If
Next k
I would appreciate suggestions to make it better or if there's an easier way to do it that would be really nice.
The duplicates are only being counted when they are next to each other because of this:
dupVal((rangeArr(j, i)), ((rangeArr(j + 1, i))))
The function goes through the entire range and literally compares each column to that column + 1. So, if there was a duplicate 2 or more columns ago, or 1 or more rows ago, the function would not detect it.
The simplest way to detect duplicates is to build a unique list of the values you do know about. Then, when you encounter a new value as you loop through the range, you compare it to that list (which in this case, is an array). If you find it in the list, you count it as a duplicate, because you've seen it before. Otherwise, it's a new value, so add it to the list. In code, this would be:
Function CountByErrorTest() As Long
Const lcol As Long = 29
Const lrow As Long = 3169
Dim uniqueArr() As Variant, find As Variant
Dim tester1 As Worksheet, tester2 As Worksheet
Dim i As Long, j As Long, k As Long, count As Long, uniqueU As Long
Dim found As Boolean
Set tester1 = Worksheets("tester")
Set tester2 = Worksheets("tester2")
uniqueU = -1
count = 0
ReDim uniqueArr(0)
uniqueArr(0) = Null
'Loop through columns
For i = 1 To lcol
'Loop through rows
For j = 1 To lrow
find = tester1.Cells(j, i).Value
found = False
'Loop through array of unique values
For k = LBound(uniqueArr) To UBound(uniqueArr)
'Check whether this is a known value
If (find = uniqueArr(k)) Then
found = True
Exit For
End If
Next k
If found = True Then
'Count the duplicate
count = count + 1
Else
'Add new value to the array
uniqueU = uniqueU + 1
ReDim Preserve uniqueArr(uniqueU)
uniqueArr(uniqueU) = find
End If
Next j
Next i
tester2.Range("g4").Value = count
CountByErrorTest = count
End Function
If you get to a point where you need to do something like this for a very large range, it may start to get slow. To make it more faster, there are data structures which can be used to more efficiently store and retrieve the unique values as you're checking through the range. Using a binary tree instead of an array would be an example of this.
EDIT: Here's an example of how you can generalise this function to accept a range as a parameter and call it from elsewhere:
Function CountByErrorTest(ByRef tester1 As Worksheet, ByRef tester2 As Worksheet, ByRef range As range) As Long
Dim uniqueArr() As Variant, find As Variant
Dim i As Long, j As Long, k As Long, count As Long, uniqueU As Long, lcols As Long, lrows As Long
Dim found As Boolean
lcols = range.Column + range.Columns.count - 1
lrows = range.Row + range.Rows.count - 1
uniqueU = -1
count = 0
ReDim uniqueArr(0)
uniqueArr(0) = Null
'Loop through columns
For i = range.Column To lcols
'Loop through rows
For j = range.Row To lrows
find = tester1.Cells(j, i).Value
found = False
'Loop through array of unique values
For k = LBound(uniqueArr) To UBound(uniqueArr)
'Check whether this is a known value
If (find = uniqueArr(k)) Then
found = True
Exit For
End If
Next k
If found = True Then
'Count the duplicate
count = count + 1
Else
'Add new value to the array
uniqueU = uniqueU + 1
ReDim Preserve uniqueArr(uniqueU)
uniqueArr(uniqueU) = find
End If
Next j
Next i
CountByErrorTest = count
End Function
Sub ExampleCallFunction()
Dim tester1 As Worksheet, tester2 As Worksheet
Dim range As range
Set tester1 = Worksheets("tester")
Set tester2 = Worksheets("tester2")
Set range = tester2.range("b4:c5") 'set what your range is here
tester2.range("g4").Value = CountByErrorTest(tester1, tester2, range)
End Sub

Compare two sheets and highlight unmatched rows using unique ID only

I want to match rows from two different sheets and highlight only in the first column of the unmatched row or better still copy the unmatched rows into a new sheet. The code should compare the rows of the two Sheets and color the new rows in the second sheet. Sheet2 (say Jan 2020) contains more rows than Sheet1 (Dec 2019) as its the recently updated sheet and they both contain rows of over 22k with both having unique ID as the first column.
My below code tries to highlight all the unmatching cells and takes longer time to finish. What I wish is for the code to just color the unmatched in column A (the vb.Red) only(since its the unique ID) while ignoring the rest of the column/cells (vb.Yellow) and or if possible copy the highlighted rows into a new sheet.
Sub RunCompare()
Call compareSheets("Sheet1", "Sheet2") 'compareSheets("2019-01 Database", "2019-02 Database")
End Sub
Sub compareSheets(shtSheet1 As String, shtSheet2 As String)
Dim c As Integer, j As Integer, i As Integer, mydiffs As Integer, cnt1 As Integer, cnt2 As Integer
Dim noexist As Integer
cnt2 = Worksheets("Sheet2").Cells.SpecialCells(xlCellTypeLastCell).Row
cnt1 = Worksheets("Sheet1").Cells.SpecialCells(xlCellTypeLastCell).Row
'For each cell in sheet2 that is not the same in Sheet1, color it yellow
For i = 1 To cnt2
For j = 1 To cnt1
If ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, 1).Value Then
For c = 2 To 22
If Not ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Value = ActiveWorkbook.Worksheets(shtSheet1).Cells(j, c).Value Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, c).Interior.Color = vbYellow
mydiffs = mydiffs + 1
End If
Next
Exit For
End If
If j = cnt1 Then
ActiveWorkbook.Worksheets(shtSheet2).Cells(i, 1).Interior.Color = vbRed
End If
Next
Next
'Display a message box to demonstrate the differences and if there is a new entry on the second sheet
'MsgBox mydiffs & ":differences found, " & noexist & ":no exist", vbInformation
ActiveWorkbook.Sheets(shtSheet2).Select
End Sub
Let's simplify the task and do it step by step.
This is how the input in the two sheets can look like:
Then, we may consider reading these and saving them to an array:
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Looping between the data in the two arrays is quite fast in vba. The writing to the third worksheet is done only once the two values from the two arrays match:
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
This is the result in the third worksheet, all matching values are in a single row:
This is how the whole code looks like:
Sub CompareTwoRanges()
Dim rangeA As Range
Dim rangeB As Range
Set rangeA = ThisWorkbook.Worksheets(1).Range("A1:Z1")
Set rangeB = ThisWorkbook.Worksheets(2).Range("A1:ZZ1")
Dim arrayA As Variant
Dim arrayB As Variant
With Application
arrayA = .Transpose(.Transpose(rangeA))
arrayB = .Transpose(.Transpose(rangeB))
End With
Dim myValA As Variant
Dim myValB As Variant
Dim currentRow As Long: currentRow = 1
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
ThisWorkbook.Worksheets(3).Cells(currentRow, 1) = myValA
currentRow = currentRow + 1
End If
Next
Next
End Sub
Note - there will be another performance bonus, if the results are written to an array and then written from the array to the worksheet. Thus the writing would happen only once. This is the change, that needs to be implemented in the code, after the array declarations:
Dim myValA As Variant
Dim myValB As Variant
Dim resultArray() As Variant
ReDim Preserve resultArray(2 ^ 20)
Dim i As Long: i = 0
For Each myValA In arrayA
For Each myValB In arrayB
If myValA = myValB Then
resultArray(i) = myValA
i = i + 1
End If
Next
Next
ReDim Preserve resultArray(i)
ThisWorkbook.Worksheets(3).Cells(1, 1).Resize(UBound(resultArray)) = Application.Transpose(resultArray)
when you get cell value, it spends time.
so, you can target Range transfer 2d Variant
Dim endRow AS Long
Dim olderRange AS Range
Dim olderVariant AS Variant
endRow = olderSheet.cells(rows.count,1).end(xlup).row
Set olderRange = olderSheet.Range(olderSheet.Cells(startRow, startCol), olderSheet.Cells(endRow, endCol))
'Transfer
olderVariant = olderRange
For currentRow = 1 to UBound(olderVariant, 1)
'Loop
'if you want change real Cell value Or interior
'add row Or Col weight
if olderVariant(currentRow, currentCol) = newerVariant(currentRow, currentCol) THen
newerSheet.Cells(currentRow+10,currentCol+10).interior.colorIndex = 3
End if
Next currentRow
In case anyone has the same kind of problem, I have found an easier way to do it. Providing your sheet2 is the comparison sheet:
Dim Ary1 As Variant, Ary2 As Variant
Dim r As Long
Ary1 = Sheets("Sheet1").UsedRange.Value2
Ary2 = Sheets("Sheet2").UsedRange.Value2
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary1)
.Item(Ary1(r, 1)) = Empty
Next r
For r = 1 To UBound(Ary2)
If Not .Exists(Ary2(r, 1)) Then Sheets("Sheet2").Cells(r, 1).Interior.Color = vbRed
Next r
End With

Match partial text string (90%) two column in two different sheet

I'm trying to match (90%) partial text string from a sheet column to another sheet column and bring end result to the master sheet column.
I found a VBA solution but I have some problems with that.
1) it's matching exact text
2) finding a problem to match two different sheet columns.
Please help me to sort this out.
Sub lookup()
Dim TotalRows As Long
Dim rng As Range
Dim i As Long
'Copy lookup values from sheet1 to sheet3
Sheets("BANK STATEMENT ENTRY").Select
TotalRows = ActiveSheet.UsedRange.Rows.Count
Range("F3:F" & TotalRows).Copy Destination:=Sheets("TEST").Range("A1")
'Go to the destination sheet
Sheets("TEST").Select
For i = 1 To TotalRows
'Search for the value on sheet2
Set rng = Sheets("INFO").UsedRange.Find(Cells(i, 1).Value)
'If it is found put its value on the destination sheet
If Not rng Is Nothing Then
Cells(i, 2).Value = rng.Value
End If
Next
End Sub
I have done a text mining project and I know you cannot use that approach, you have to break the strings into substrings and then analyze them. It will be a whole project, but you are lucky since I did it for you.
Let's simplify the problem and say that you have two ranges of strings and you want to find every similar strings between two groups. Also, you want to have a tolerance to minimize the matching pairs.
Assume ABCDE and 12BCD00. They have B, C, D, BC, CD and BCD in common. So the longest common substring is BCD which is 3 characters: 3/length of ABCDE(5) will be 60% similarity with the first string and 3/7=43% similarity. So if you can get a list of all those common substrings among all the strings in two ranges you can come up with a better list to filter and get what you want.
I wrote a bunch of functions. To use it easily, just copy and paste both groups of strings in one sheet and generate the final report on the same sheet too to understand how it works.
Function FuzzyFind, finds all of the common substrings and gives you 1st string from Group1/range1, 2nd string from group2/range2, common substring and percentages of similiarity for both strings. The good thing is you can tell the function how small you want your substrings e.g. in the previous example, if you say iMinCommonSubLength=3, it will only give you BCD, if you say iMinCommonSubLength=2 it will give you BC, CD and BCD and so on.
Use function Main. I also included a Test sub.
Functions:
Sub TestIt()
Call Main(ActiveSheet.Range("A1:A10"), ActiveSheet.Range("B1:B10"), 4, ActiveSheet.Range("D1"))
End Sub
Sub Main(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer, Optional rngReportUpperLeftCell As Range)
Dim arr() As Variant
Dim rngReport As Range
If rngReport Is Nothing Then Set rngReport = ActiveSheet.Range("A1")
arr = FuzzyFind(rng1, rng2, iMinCommonSubLength)
Set rngReport = rngReportUpperLeftCell.Resize(UBound(arr, 1), UBound(arr, 2))
rngReport.Value = arr
rngReport.Columns(1).NumberFormat = "#"
rngReport.Columns(2).NumberFormat = "#"
rngReport.Columns(3).NumberFormat = "#"
rngReport.Columns(4).NumberFormat = "0%"
rngReport.Columns(5).NumberFormat = "0%"
End Sub
Function GetCharacters(str As String) As Variant
Dim arr() As String
ReDim arr(Len(str) - 1)
For i = 1 To Len(str)
arr(i - 1) = Mid$(UCase(str), i, 1)
Next
GetCharacters = arr
End Function
Function GetIterations(iStringLength As Integer, iSubStringLength As Integer) As Integer
If iStringLength >= iSubStringLength Then
GetIterations = iStringLength - iSubStringLength + 1
Else
GetIterations = 0
End If
End Function
Function GetSubtrings(str As String, iSubLength As Integer) As Variant
Dim i As Integer
Dim count As Integer
Dim arr() As Variant
count = GetIterations(Len(str), iSubLength)
ReDim arr(1 To count)
For i = 1 To count
arr(i) = Mid(str, i, iSubLength)
Next i
GetSubtrings = arr()
End Function
Function GetLongestCommonSubStrings(str1 As String, str2 As String, iMinCommonSubLeng As Integer)
Dim i As Integer
Dim iLongestPossible As Integer
Dim iShortest As Integer
Dim arrSubs() As Variant
Dim arr1() As Variant
Dim arr2() As Variant
ReDim arrSubs(1 To 1)
'Longest possible common substring length is the smaller string's length
iLongestPossible = IIf(Len(str1) > Len(str2), Len(str2), Len(str1))
If iLongestPossible < iMinCommonSubLeng Then
'MsgBox "Minimum common substring length is larger than the shortest string." & _
' " You have to choose a smaller common length", , "Error"
Else
'We will try to find the first match of common substrings of two given strings, exit after the first match
For i = iLongestPossible To iMinCommonSubLeng Step -1
arr1 = GetSubtrings(str1, i)
arr2 = GetSubtrings(str2, i)
ReDim arrSubs(1 To 1)
arrSubs = GetCommonElement(arr1, arr2)
If arrSubs(1) <> "" Then Exit For 'if you want JUST THE LONGEST MATCH, comment out this line
Next i
End If
GetLongestCommonSubStrings = arrSubs
End Function
Function GetCommonElement(arr1() As Variant, arr2() As Variant) As Variant
Dim i As Integer
Dim j As Integer
Dim count As Integer
Dim arr() As Variant
count = 1
ReDim arr(1 To count)
For i = 1 To UBound(arr1)
For j = 1 To UBound(arr2)
If arr1(i) = arr2(j) Then
ReDim Preserve arr(1 To count)
arr(count) = arr1(i)
count = count + 1
End If
Next j
Next i
GetCommonElement = arr
End Function
Function FuzzyFind(rng1 As Range, rng2 As Range, iMinCommonSubLength As Integer) As Variant
Dim count As Integer
Dim i As Integer
Dim arrSubs As Variant
Dim str1 As String
Dim str2 As String
Dim cell1 As Range
Dim cell2 As Range
Dim rngReport As Range
Dim arr() As Variant 'array of all cells that are partially matching, str1, str2, common string, percentage
count = 1
ReDim arr(1 To 5, 1 To count)
For Each cell1 In rng1
str1 = UCase(CStr(cell1.Value))
If str1 <> "" Then
For Each cell2 In rng2
str2 = UCase(CStr(cell2.Value))
If str2 <> "" Then
ReDim arrSubs(1 To 1)
arrSubs = GetLongestCommonSubStrings(str1, str2, iMinCommonSubLength)
If arrSubs(1) <> "" Then
For i = 1 To UBound(arrSubs)
arr(1, count) = cell1.Value
arr(2, count) = cell2.Value
arr(3, count) = arrSubs(i)
arr(4, count) = Len(arrSubs(i)) / Len(str1)
arr(5, count) = Len(arrSubs(i)) / Len(str2)
count = count + 1
ReDim Preserve arr(1 To 5, 1 To count)
Next i
End If
End If
Next cell2
End If
Next cell1
FuzzyFind = TransposeArray(arr)
End Function
Function TransposeArray(arr As Variant) As Variant
Dim arrTemp() As Variant
ReDim arrTemp(LBound(arr, 2) To UBound(arr, 2), LBound(arr, 1) To UBound(arr, 1))
For a = LBound(arr, 2) To UBound(arr, 2)
For b = LBound(arr, 1) To UBound(arr, 1)
arrTemp(a, b) = arr(b, a)
Next b
Next a
TransposeArray = arrTemp
End Function
Don't forget to clear the sheet before generating new reports. Insert a table and use its autofilter to easily filter your stuff.
last but not least, don't forget to click on the check mark to announce this as the answer to your question.

Remove duplicates from array using VBA

Assume I have a block of data in Excel 2010, 100 rows by 3 columns.
Column C contains some duplicates, say it starts off as
1, 1, 1, 2, 3, 4, 5, ..... , 97, 98
Using VBA, I would like to remove the duplicate rows so I am left with 98 rows and 3 columns.
1, 2, 3, ..... , 97, 98
I know there is a button in Excel 2010 to do that but it inteferes with the rest of my code subsequently and gives incorrect results.
Furthermore, I would like to do it in arrays, then paste the results on the worksheet, rather than methods such as Application.Worksheetfunction.countif(.....
So something like:
Dim myarray() as Variant
myarray=cells(1,1).Currentregion.value
Dim a as Long
For a=1 to Ubound(myarray,1)
'something here to
Next a
I answered a similar question. Here is the code I used:
Dim dict As Object
Dim rowCount As Long
Dim strVal As String
Set dict = CreateObject("Scripting.Dictionary")
rowCount = Sheet1.Range("A1").CurrentRegion.Rows.Count
'you can change the loop condition to iterate through the array rows instead
Do While rowCount > 1
strVal = Sheet1.Cells(rowCount, 1).Value2
If dict.exists(strVal) Then
Sheet1.Rows(rowCount).EntireRow.Delete
Else
'if doing this with an array, then add code in the Else block
' to assign values from this row to the array of unique values
dict.Add strVal, 0
End If
rowCount = rowCount - 1
Loop
Set dict = Nothing
If you want to use an array, then loop through the elements with the same conditional (if/else) statements. If the item doesn't exist in the dictionary, then you can add it to the dictionary and add the row values to another array.
Honestly, I think the most efficient way is to adapt code you'd get from the macro recorder. You can perform the above function in one line:
Sheet1.UsedRange.RemoveDuplicates Columns:=3, Header:=xlYes
Function eliminateDuplicate(poArr As Variant) As Variant
Dim poArrNoDup()
dupArrIndex = -1
For i = LBound(poArr) To UBound(poArr)
dupBool = False
For j = LBound(poArr) To i
If poArr(i) = poArr(j) And Not i = j Then
dupBool = True
End If
Next j
If dupBool = False Then
dupArrIndex = dupArrIndex + 1
ReDim Preserve poArrNoDup(dupArrIndex)
poArrNoDup(dupArrIndex) = poArr(i)
End If
Next i
eliminateDuplicate = poArrNoDup
End Function
Simple function to remove duplicates from a 1D array
Private Function DeDupeArray(vArray As Variant) As Variant
Dim oDict As Object, i As Long
Set oDict = CreateObject("Scripting.Dictionary")
For i = LBound(vArray) To UBound(vArray)
oDict(vArray(i)) = True
Next
DeDupeArray = oDict.keys()
End Function
Edit:
With stdVBA (a library largely maintained by myself) you can use:
uniqueValues = stdEnumerator.CreateFromArray(myArray).Unique().AsArray()
An improvement on #RBILLC and #radoslav006 answers, this version searches the array with the duplicates removed for existing values so it searchs less values to find a duplicate.
Public Function RemoveDuplicatesFromArray(sourceArray As Variant)
Dim duplicateFound As Boolean
Dim arrayIndex As Integer, i As Integer, j As Integer
Dim deduplicatedArray() As Variant
arrayIndex = -1
deduplicatedArray = Array(1)
For i = LBound(sourceArray) To UBound(sourceArray)
duplicateFound = False
For j = LBound(deduplicatedArray) To UBound(deduplicatedArray)
If sourceArray(i) = deduplicatedArray(j) Then
duplicateFound = True
Exit For
End If
Next j
If duplicateFound = False Then
arrayIndex = arrayIndex + 1
ReDim Preserve deduplicatedArray(arrayIndex)
deduplicatedArray(arrayIndex) = sourceArray(i)
End If
Next i
RemoveDuplicatesFromArray = deduplicatedArray
End Function
Here's another approach for working with an array:
Sub tester()
Dim arr, arrout
arr = Range("A1").CurrentRegion.Value 'collect the input array
arrout = UniqueRows(arr) 'get only unique rows
Range("H1").Resize(UBound(arrout, 1), UBound(arrout, 2)).Value = arrout
End Sub
Function UniqueRows(arrIn As Variant) As Variant
Dim keys, rw As Long, col As Long, k, sep, arrout
Dim dict As Object, lbr As Long, lbc As Long, ubr As Long, ubc As Long, rwOut As Long
Set dict = CreateObject("scripting.dictionary")
'input array bounds
lbr = LBound(arrIn, 1)
ubr = UBound(arrIn, 1)
lbc = LBound(arrIn, 2)
ubc = UBound(arrIn, 2)
ReDim keys(lbr To ubr)
'First pass:collect all the row "keys" in an array
' and unique keys in a dictionary
For rw = lbr To ubr
k = "": sep = ""
For col = lbc To ubc
k = k & sep & arrIn(rw, col)
sep = Chr(0)
Next col
keys(rw) = k 'collect key for this row
dict(k) = True 'just collecting unique keys
Next rw
'Resize output array to # of unique rows
ReDim arrout(lbr To dict.Count + (lbr - 1), lbc To ubc)
rwOut = lbr
'Second pass: copy each unique row to the output array
For rw = lbr To ubr
If dict(keys(rw)) Then 'not yet output?
For col = lbc To ubc 'copying this row over to output...
arrout(rwOut, col) = arrIn(rw, col)
Next col
rwOut = rwOut + 1 'increment output "row"
dict(keys(rw)) = False 'flag this key as copied
End If
Next rw
UniqueRows = arrout
End Function
Answer from #RBILLC could be easily improved by adding an Exit For inside internal loop:
Function eliminateDuplicate(poArr As Variant) As Variant
Dim poArrNoDup()
dupArrIndex = -1
For i = LBound(poArr) To UBound(poArr)
dupBool = False
For j = LBound(poArr) To i
If poArr(i) = poArr(j) And Not i = j Then
dupBool = True
Exit For
End If
Next j
If dupBool = False Then
dupArrIndex = dupArrIndex + 1
ReDim Preserve poArrNoDup(dupArrIndex)
poArrNoDup(dupArrIndex) = poArr(i)
End If
Next i
eliminateDuplicate = poArrNoDup
End Function
I think this is really a case for using excel's native functions, at least for the initial array acquisition, and I don't think there's any simpler way to do it. This sub will output the unique values starting in column 5. I assumed that the target range was empty, so if it's not, change r and c.
Sub testUniques()
Dim arr, r As Long, c As Long, h As Long, w As Long
Dim this As Worksheet: Set this = ActiveSheet
arr = Application.Unique(this.Cells(1, 1).CurrentRegion)
r = 1
c = 5
h = UBound(arr, 1) - 1
w = UBound(arr, 2) - 1
this.Range(this.Cells(r, c), this.Cells(r + h, c + w)) = arr
End Sub
I know this is old, but here's something I used to copy duplicate values to another range so that I could see them quickly to establish data integrity for a database I was standing up from various spreadsheets. To make the procedure delete the duplicates it would be as simple as replacing the dupRng lines with Cell.Delete Shift:=xlToLeft or something to that effect.
I haven't tested that personally, but it should work.
Sub PartCompare()
Dim partRng As Range, partArr() As Variant, i As Integer
Dim Cell As Range, lrow As Integer
lrow = ThisWorkbook.Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
i = 0
Set partRng = ThisWorkbook.Worksheets("Sheet1").Range(Cells(1, 1), Cells(lrow, 1))
For Each Cell In partRng.Cells
ReDim Preserve partArr(i)
partArr(i) = Cell.Value
i = i + 1
Next
Dim dupRng As Range, j As Integer, x As Integer, c As Integer
Set dupRng = ThisWorkbook.Worksheets("Sheet1").Range("D1")
x = 0
c = 1
For Each Cell In partRng.Cells
For j = c To UBound(partArr)
If partArr(j) = Cell.Value Then
dupRng.Offset(x, 0).Value = Cell.Value
dupRng.Offset(x, 1).Value = Cell.Address()
x = x + 1
Exit For
End If
Next j
c = c + 1
Next Cell
End Sub
Remove duplicates (plus related row items) from array
As OP wanted a VBA solution close to RemoveDuplicates, I demonstrate an array approach using a â–ºdictionary to get not the unique items per se (dict.keys), but the related row indices of first occurrencies (dict.items).
These are used to retain the whole row data via procedure LeaveUniques profiting from the advanced possibilities of the â–ºApplication.Index() function - c.f. Some peculiarities of the the Application.Index function
Example Call
Sub ExampleCall()
'[0]define range and assign data to 1-based 2-dim datafield
With Sheet1 ' << reference to your project's sheet Code(Name)
Dim lastRow: lastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Dim rng: Set rng = .Range("C2:E" & lastRow)
End With
Dim data: data = rng ' assign data to 2-dim datafield
'[1]get uniques (column 1) and remove duplicate rows
LeaveUniques data ' << call procedure LeaveUniques (c.f. RemoveDuplicates)
'[2]overwrite original range
rng.Clear
rng.Resize(UBound(data), UBound(data, 2)) = data
End Sub
Procedure LeaveUniques
Sub LeaveUniques(ByRef data As Variant, Optional ByVal colNum As Long = 1)
'Purpose: procedure removes duplicates of given column number in entire array
data = Application.Index(data, uniqueRowIndices(data, colNum), nColIndices(UBound(data, 2)))
End Sub
Help functions to LeaveUniques
Function uniqueRowIndices(data, Optional ByVal colNum As Long = 1)
'Purpose: return data index numbers referring to uniques
'a) set late bound dictionary to memory
Dim dict As Object
Set dict = CreateObject("Scripting.Dictionary")
'b) slice e.g. first data column (colNum = 1)
Dim colData
colData = Application.Index(data, 0, colNum)
'c) fill dictionary with uniques referring to first occurencies
Dim i As Long
For i = 1 To UBound(colData)
If Not dict.exists(dict(colData(i, 1))) Then dict(colData(i, 1)) = i
Next
'd) return 2-dim array of valid unique 1-based index numbers
uniqueRowIndices = Application.Transpose(dict.items)
End Function
Function nColIndices(ByVal n As Long)
'Purpose: return "flat" array of n column indices, e.g. for n = 3 ~> Array(1, 2, 3)
nColIndices = Application.Transpose(Evaluate("row(1:" & n & ")"))
End Function

Resources