Reverse order of For Each loop - vba

One of the most powerful things about VB is ability to loop through objects in a collection WITHOUT referring to the index - for each loop.
I find it very useful only want to remove objects from a collection.
When doing removing objects from a predefined such as rows on a spread sheet the code is simpler if I use indexing and start at the largest and work back to the first. (Step -1 with an iterator) (otherwise requires an offset as the For each moves the enumerator pointer back to the previous object once the active one is deleted)
eg.
For intA = 10 to 1 step -1
' ...
Next
What about when using a For Each | Next
eg.
For each rngCell in Selection.Cells
' ...
Next
How could I loop backwards using the for each loop syntax?

It's not possible to loop backwards using the for each loop syntax.
As an alternative you can use a For i = a To 1 Step -1 loop:
Sub reverseForEach()
Dim i As Long, rng As Range
Set rng = ActiveSheet.Range("A1:B2")
For i = rng.Cells.Count To 1 Step -1
Debug.Print rng.item(i).Address
' Or shorthand rng(i) as the Item property
' is the default property for the Range object.
' Prints: $B$2, $A$2, $B$1, $A$1
Next i
End Sub
This works with all collections that have the Item property. For instance Worksheets, Areas or Shapes.
Note: The order of the loop when using on the Range object is from right to left, then up.

For built in collections (eg a Range) the short answer is: you can't. For user defined collections the answer linked by #VBlades might be useful, although the cost might outweigh the benifit.
One work around is to seperate the identification of items to be removed from the actual removal. Eg, for a range, build up a new range variable using Union, then process that variable, eg delete all the rows in one go. For the Range example, you can also take advantage of the Variant Array method to further speed things up.
Whether or not any of this is useful will depend on your actual use case.

There are other good answers but here's another alternative method of "stepping backwards" through a Range.
Function to Invert Range into Array
This function returns a "backwards Range Array" that can be used with For..Each:
Function ReverseRange(rg As Range) As Range()
Dim arr() As Range, r As Long, c As Long, n As Long
With rg
ReDim arr(1 To .Cells.Count) 'resize Range Array
For r = .Cells(.Rows.Count, 1).Row To .Cells(1, 1).Row Step -1
For c = .Cells(1, .Columns.Count).Column To .Cells(1, 1).Column Step -1
n = n + 1
Set arr(n) = .Worksheet.Cells(r, c) 'set cell in Array
Next c
Next r
End With
ReverseRange = arr 'return Range Array as function result
End Function
Example Usage:
Sub test()
Dim oCell
For Each oCell In ReverseRange(ActiveSheet.Range("E5:A1"))
Debug.Print oCell.Address 'do something here with each cell
Next oCell
End Sub

use a second variable that is set as your wanted counter and use this one in your code
'ex: Loop from n = 19 to 16
For i = 0 To 3
n = 19 - i
'your code here using n as the counter
Next

Only for Range collections. They are more complicated if they have more than 1 Area.
Basically there are two loops, the first one keeps the index of all the cells in an array and the second one creates a union of ranges from back to front
Option Explicit
Private Sub Main()
Dim InvertedRange As Range
Set InvertedRange = InvertRange(Application.Union(ActiveSheet.Range("A1:A2"), _
ActiveSheet.Range("F6:F7"), ActiveSheet.Range("E4:F5"), ActiveSheet.Range("E1")))
Dim ActualRange As Range
For Each ActualRange In InvertedRange
Debug.Print (ActualRange.Address(False, False) & " : " & ActualRange.Value)
Next ActualRange
End Sub
Public Function InvertRange(ByVal rngRange_I As Range) As Range
Dim RangesArray() As Long
ReDim RangesArray(1 To rngRange_I.Count, 1 To rngRange_I.Count)
Dim ActualArea As Range
Dim ActualRange As Range
Dim ArrayIndex As Long
For Each ActualArea In rngRange_I.Areas
For Each ActualRange In ActualArea
ArrayIndex = ArrayIndex + 1
RangesArray(ArrayIndex, 1) = ActualRange.Row
RangesArray(ArrayIndex, 2) = ActualRange.Column
Next ActualRange
Next ActualArea
Dim ActualRow As Long
Dim ActualColumn As Long
ActualRow = RangesArray(UBound(RangesArray, 1), 1)
ActualColumn = RangesArray(UBound(RangesArray, 2), 2)
With rngRange_I.Worksheet
Dim InvertedRange As Range
Set InvertedRange = .Cells(ActualRow, ActualColumn)
For ArrayIndex = UBound(RangesArray, 1) To LBound(RangesArray, 1) Step -1
ActualRow = RangesArray(ArrayIndex, 1)
ActualColumn = RangesArray(ArrayIndex, 2)
Set InvertedRange = Application.Union(InvertedRange, _
.Cells(ActualRow, ActualColumn))
Next ArrayIndex
End With
Set InvertRange = InvertedRange
End Function

You can use a stack (LIFO data structure) for inventing your list and the code would be something like this:
Dim aStack as Object
Set aStack = CreateObject("System.Collections.Stack")
For Each arngCell in Selection.Cells
aStack.Push(arngCell)
Next
While aStack.Count > 0
rngCell = aStack.Pop
' ...
End While
Set stack = Nothing

Related

VBA solution for very slow Countif formula

I have a solution that works in Excel with a countif formula (with the help of another Stackoverflow user).
Essentially what this countif formula does is count the first instance of an ID that exclusively exists with the classification type "DC". For example, as you can see in my snippet, 2232 is marked with as it is only exists with the classification "DC". Whilst in the case of 2240 it is marked as 0 as there are multiple classifications possible.
The formula in column D is the following:
=IF(IF(B2<>"DC",0,AND(COUNTIF(C$2:C$28,C2)=COUNTIF(A$2:A$28,A2),COUNTIF(A$2:A2,A2)=1)),1,0)
The problem that I am experiencing is that this is an extremely slow formula to process for Excel -- it takes roughly ~10-15 mins to complete. The database that I am running this on contains of roughly 150k~ lines.
I was wondering if it was possible to do this same process in VBA, but a lot faster and more efficient than the current processing time.
So I am using the following piece of VBA code to try to recreate the same results:
Sub MarkUniqueID()
Dim Ary As Variant, Nary As Variant
Dim r As Long
With ThisWorkbook.Sheets("sheet1")
Ary = .Range("A2", .Range("A" & Rows.Count).End(xlUp)).Value2
End With
ReDim Nary(1 To UBound(Ary), 1 To 1)
With CreateObject("scripting.dictionary")
For r = 1 To UBound(Ary)
If Not .Exists(Ary(r, 1)) Then
.Add Ary(r, 1), Nothing
Nary(r, 1) = 1
Else
Nary(r, 1) = 0
End If
Next r
End With
ThisWorkbook.Sheets("sheet1").Range("E2").Resize(r).Value = Nary
End Sub
Which runs the process much smoother it takes only a few ~seconds of my original time, however, I am not sure how I can add one more criteria into my array (i.e. only exclusively consider "DC"), as now the results are not what I want (see below).
Any pointers would be much appreciated!
You can use another dictionary to track which ID's should be excluded:
Sub MarkUniqueID()
Dim Ary As Variant, Nary() As Long, cls, id, k
Dim r As Long, dictIn As Object, dictOut As Object
Dim ws As Worksheet
Set dictIn = CreateObject("scripting.dictionary")
Set dictOut = CreateObject("scripting.dictionary")
Set ws = ThisWorkbook.Sheets("sheet1")
'pick up the classification and ID
Ary = ws.Range("B2:C" & ws.Cells(ws.Rows.Count, "B").End(xlUp).Row).Value
ReDim Nary(1 To UBound(Ary), 1 To 1)
For r = 1 To UBound(Ary, 1)
cls = Ary(r, 1)
id = CStr(Ary(r, 2))
If cls = "DC" Then
If Not dictIn.exists(id) Then dictIn.Add id, r
Else
If Not dictOut.exists(id) Then dictOut.Add id, True
End If
Next r
For Each k In dictIn
If Not dictOut.exists(k) Then Nary(dictIn(k), 1) = 1
Next k
ws.Range("E2").Resize(UBound(Nary, 1)).Value = Nary
End Sub

Excel VBA find all values in row and save different column values to variables

I've done quite a bit of searching and can't find any code that matches my situation or to a point I can modify except for one.
Looking at the spreadsheet below. I want to have the user enter the OrderNumber then search Column A for every value of that number. As it does I want it to copy the ItemNumber and QtyOrdered to two different variables in order to put them into textboxes later on.
I want it to "stack" the information into the variable so something like ItemNumValues = ItemNumValues + Cell.Value
I tried to modify code from someone else ("their code") but I am getting a mismatch type error. The rest of the code works. There are some trace elements in the script from previous features that aren't used and I just haven't removed them yet.
'***********************************************************
'********** Their Code Follows *****************
'***********************************************************
Dim numentries As Integer
Dim i As Integer
'***********************************************************
'Get number of entries
numentries = Worksheets(Sheet1).UsedRange.Rows.Count
'*************************************************************
'Run loop to cycle through all entries (rows) to copy
For i = 1 To numentries
If (Worksheets("Sheet1").Cells(i + 2, 1).Value = InStr(1, Cell, OrderNumber, vbTextCompare)) Then
MsgBox Test
End If
Next i
End If
'***********************************************************
'********** End Their Code *****************
'***********************************************************
I recommend using a multidimensional array. If you've never used arrays before, I strongly suggest reading up on them.
Sub GatherData()
Dim c As Range
Dim aGetData() As Variant 'This is our array
Dim i As Integer
Dim a As Integer
Dim iRowCount As Integer
Dim sRange As String
'Gather data
iRowCount = Worksheets("Sheet1").UsedRange.Rows.Count
For Each c In Range("A2:A" & iRowCount)
If c.Value = 636779 Then
ReDim Preserve aGetData(2, i) 'An array must have a set size but as we
'do not know how many order numbers will be found we have to 'resize'
'the array to account for how many we do find. Using "ReDim Preserve"
'keeps any data we have placed into the array while at the same time
'changing it's size.
For a = 0 To 2 'Our first index will hold each col of data that is why
'it is set to 2 (arrays start at a base of zero, so
'0,1,2 will be each col(A,B,C)
aGetData(a, i) = c.Offset(0, a) 'This gets each value from col A,B and C
Next a
i = i + 1 'Increment for array in case we find another order number
'Our second index "aGetData(index1,index2) is being resized
'this represents each order number found on the sheet
End If
Next c
'How to read the array
For i = 0 To UBound(aGetData())
For a = 0 To 2
Debug.Print aGetData(a, i)
Next a
Next i
End Sub
It seems that the OrderNumber (column A) is sorted. Very good news (if they're not, just sort them ;) ). This simple function will get you the ItemNumbers and QtyOrdered into a bi-dimensional array, where each row is a pair of them.
Function ArrItemQty(ByVal OrderNumber As Long)
With Worksheets("Sheet1").UsedRange.Offset(1)
.AutoFilter 1, OrderNumber
ArrItemQty= .Resize(, 2).Offset(, 1).SpecialCells(xlCellTypeVisible).value
.Parent.AutoFilterMode = False
End With
End Function
And here's a little testing:
Sub Test()
Dim i As Long, j As Long, ar
ar = ArrItemQty(636779)
For i = LBound(ar, 1) To UBound(ar, 1)
Debug.Print
For j = LBound(ar, 2) To UBound(ar, 2): Debug.Print ar(i, j),: Next
Next
End Sub
p.s. be aware that the resulting array is 1-based. Use LBound and UBound as indicated is safest.

COUNTIF() in 'For' loop

I have a column with nearly 100k and am trying to determine how many times a value occurs repeatedly in that column. I can do it row by row currently, but this is menial as a programmer, through something like =COUNTIF(D:D,D2). Yet that only returns D2 matches in column D.
I need to iterate through all values of D returning countif, therefore revealing all of the values repetitions in the column. I can remove duplicates later! So I have a dev. button a basic sub, or function (man this is new to me) and something along the lines of the most basic for loop ever. Just getting caught up on how to implement the COUNTIF() to to the loop properly.
Right now I'm looking at:
Sub doloop()
Dim i As Integer
i = 1
Do While i < D.Length
Cells(i, 8).Value =CountIf(D:D,D[i])
i = i + 1
Loop
End Sub
That code is incorrect obviously but it is where I'm at and may help for anyone more familiar with other languages.
Use Application.WorksheetFunction.CountIf() in your loop.
Private Sub doloop()
Dim lastRow As Long
Dim d As Double
Dim r As Range
Dim WS As Excel.Worksheet
Dim strValue As String
Dim lRow As Long
'Build your worksheet object
Set WS = ActiveWorkbook.Sheets("sheet1")
'Get the last used row in column A
lastRow = WS.Cells(WS.Rows.count, "D").End(xlUp).Row
'Build your range object to be searched
Set r = WS.Range("D1:D" & lastRow)
lRow = 1
WS.Activate
'Loop through the rows and do the search
Do While lRow <= lastRow
'First, get the value we will search for from the current row
strValue = WS.Range("D" & lRow).Value
'Return the count from the CountIf() worksheet function
d = Application.worksheetFunction.CountIf(r, strValue)
'Write that value to the current row
WS.Range("H" & lRow).Value = d
lRow = lRow + 1
Loop
End Sub
I believe you are trying to write the value to the cell, that is what the above does. FYI, if you want to put a formula into the cell, here is how that is done. Use this in place of WS.Range("H" & lRow).Value = d
WS.Range("H" & lRow).Formula = "=CountIf(D:D, D" & lRow & ")"
Sounds like you may want to look into using tables in Excel and capitalizing on their features like filtering and equation autofill. You may also be interested in using a PivotTable to do something very similar to what you're describing.
If you really want to go about this the programmatic way, I think the solution Matt gives answers your question about how to do this using CountIf. There's a big detriment to using CountIf though, in that it's not very computationally efficient. I don't think the code Matt posted will really be practical for processing the 100K rows mentioned in the OP (Application.ScreenUpdating = false would help some). Here's an alternative method that's a lot more efficient, but less intuitive, so you'll have to decide what suites your needs and what you feel conformable with.
Sub CountOccurances()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("E1:E100000")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Overwrite original array values with count of that value
For i = 1 To UBound(A)
A(i, 1) = d(A(i, 1))
Next
'Write resulting array to output range
ROutput = A
End Sub
You can also modify this to include the removal of replicates you mentioned.
Sub CountOccurances_PrintOnce()
'Define Input and Output Ranges
'The best way to do this may very from case to case,
'So it should be addressed seperately
'Right now we'll assume current sheet rows 1-100K as OP specifies
Dim RInput, ROutput As Range
Set RInput = Range("D1:D100000")
Set ROutput = Range("F1:F9")
'Define array for housing and processing range values
Dim A() As Variant
ReDim A(1 To RInput.Rows.Count, 0)
'Use Value2 as quicker more accurate value
A = RInput.Value2
'Create dictionary object
Set d = CreateObject("Scripting.Dictionary")
'Loop through array, adding new values and counting values as you go
For i = 1 To UBound(A)
If d.Exists(A(i, 1)) Then
d(A(i, 1)) = d(A(i, 1)) + 1
Else
d.Add A(i, 1), 1
End If
Next
'Print results to VBA's immediate window
Dim sum As Double
For Each K In d.Keys
Debug.Print K & ": " & d(K)
sum = sum + d(K)
Next
Debug.Print "Total: " & sum
End Sub

How to Populate Multidimensional Array in Excel Macro using For Each Loop With Formula?

I want to populate Array in VBA , using for each-loop but unable to do that
Dim MyArray() As Variant
Dim RowCounter As Integer
Dim ColCounter As Integer
Dim rCell As Range
Dim rRng As Range
Set rRng = Sheet1.Range("B10:Z97")
RowCounter = 0
ColCounter = 0
ReDim MyArray(rRng.Rows.Count, rRng.Columns.Count) 'Answer by #varocarbas
For Each rCol In rRng.Columns
For Each rCell In rCol.Rows
If IsNumeric(rCell.Value) And (Not (IsEmpty(rCell.Value))) And (Len(rCell.Value) <> 0) Then
'ReDim Preserve MyArray(RowCounter, ColCounter) -- Old Logic which cause Error
MyArray(RowCounter, ColCounter) = rCell.Value
RowCounter = RowCounter + 1
Else
'Debug.Print rCell.Value & " is not an Integer" & vbNewLine
End If
Next rCell
ColCounter = ColCounter + 1
RowCounter = 0
Next rCol
But ReDim Preserve MyArray(RowCounter, ColCounter) in this line I got subscript error , when ReDim Preserve MyArray(1, 0)
I want to read the value from excel sheet populate the array then do some calculation and update the value of Last Cell of the each Column in Excel from by Calculate Value of the Excel.
Update in code
Function RunSquareOfVariance(temperature As Integer, cellValue As Variant) As Double
RunSquareOfVariance = "=IF((" & temperature + cellValue & ")<0,0,(" & temperature + cellValue & "))*IF((" & temperature + cellValue & ")<0,0,(" & temperature + cellValue & "))"
End Function
If within the code I change the bellow line
MyArray(RowCounter, ColCounter) = RunSquareOfVariance(StantardTemperature, rCell.Value)
Now within MyArray(0,0) Value store As =IF((-16.8)<0,0,(-16.8))*IF((-16.8)<0,0,(-16.8))
But I want to store the value of the formula Withing MyArray(0,0) = ValueOftheFormula
As far as I can remember you can change size ONLY of the last array dimension.
To be sure I've just checked and it's true. According to MSDN:
If you use the Preserve keyword, you can resize only the last array
dimension and you can't change the number of dimensions at all.
I don't know the ultimate goal of your sub therefore is difficult to suggest any changes. However, you could consider working with array of arrays. Syntax of such solution works as follows:
Dim arrA() As Variant
Dim arrB() As Variant
...
ReDim Preserve arrA(RowCounter)
ReDim Preserve arrB(ColCounter)
...
arrA(RowCounter) = x
arrB(ColCounter) = y
...
Dim arrAB
arrAB = Array(arrA, arrB)
...
'to get elements of array you need to call it in this way:
arrAB(0)(RowCounter) >> to get x
arrAB(1)(ColCounter) >> to get y
There are some disadvantages of such solution but could be useful in other situation.
You could do simply:
Dim rng As Range
Dim myArray() As Variant
Set rRng = Sheet1.Range("B10:Z97")
myArray = rRng.Value
You will also need to For Each rCell In rRng.Rows instead of For Each rCell In rCol.Rows. Otherwise, like Kaz says, you can only resize the last dimension of an array.
OK Problem solved
MyArray(RowCounter, ColCounter) = Application.Evaluate
(
RunSquareOfVariance(StantardTemperature, rCell.Value)
)
I can see you have found a solution for your issue. For future reference, I would like to add an alternative way of going about this.
In particular, I agree with #DavidZemens ’s approach on copying the range values to a variant array directly. It is a very elegant, simple and efficient solution. The only tricky part is when there are empty or non-numeric cells in the range you are looking, and you do not want to insert these values. A modification of David’s approach would work in case some of the values you are copying are not numbers.
Sub CopyNumbersToArray()
Dim var As Variant, rng As Range
' Grab the numeric values of the range only. Checking if cell is empty or
' if it has a positive length is not needed
Set rng = Range("B3:K3").SpecialCells(xlCellTypeConstants, xlNumbers)
' Copy the numbers. Note that var=rng.value will not work if rng is not contiguous
rng.Copy
' Paste the numbers temporarily to a range that you do not use
Range("A10000").Resize(1, rng.Count).PasteSpecial xlPasteValues
' Set rng object to point to that range
Set rng = Range(Cells(10000, 1), Cells(10000, rng.Count))
' Store the values that you need in a variant array
var = rng.Value
' Clear the contents of the temporary range
rng.ClearContents
End Sub
For more than 2 dimensions, jagged arrays is probably a good way to go (as suggested by #KazJaw)

Make a new column without duplicates VBA?

I have a column of cells whose values are something like this:
a
a
b
b
c
c
c
c
d
e
f
f
etc.
I'm looking to take the non-duplicated values and paste them into a new column. My pseudocode for this is as follows:
ActiveSheet.Range("a1").End(xlDown).Select
aend = Selection.Row
for acol= 1 to aend
ActiveSheet.Range("b1").End(xlDown).Select
bend = Selection.Row
'if Cells(1,acol).Value <> any of the values in the range Cells(2,1).Value
'to Cells(2,bend).Value, then add the value of Cells(1,acol) to the end of
'column b.
Does my logic in this make sense? I'm not sure how to code the commented portion. If this isn't the most efficient way to do it, could someone suggest a better way? Thanks so much!
Depending on which version of Excel you are using, you can use some built-in Excel functionality to obtain what you want- the whole solution depends on your level of skill with VBA.
Excel 2003:
You can use the Advancedfilter method (documentation) of your range to obtain the unique values and copy them to your target area. Example:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
End With
Where B1 is the first cell of the column you wish to copy the unique values to. The only problem with this method is that the first row of the source column ("A1") will be copied to the target range even if it is duplicated. This is because the AdvancedFilter method assumes that the first row is a header.
Therefore, adding an additional code line we have:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("B1"), Unique:=True
.Range("B1").Delete Shift:=xlShiftUp
End With
Excel 2007 / 2010:
You can use the same method as above, or use the RemoveDuplicates method (documentation). This is similar to the AdvancedFilter method, except that RemoveDuplicates works in-place, which means you need to make a duplicate of your source column and then perform the filtering, for example:
With ActiveSheet
.Range("A1", .Range("A1").End(xlDown)).Copy Destination:=.Range("B1")
.Range("B1", .Range("B1").End(xlDown)).RemoveDuplicates Columns:=1, Header:=xlNo
End With
The final parameter Header controls whether the first cell of the source data is copied to the destination (if it's set to true then the method similarly to the AdvancedFilter method).
If you're after a "purer" method, then you can use a VBA Collection or dictionary - I am sure that someone else will offer a solution with this.
I use a collection, which can't have duplicate keys, to get the unique items from a list. Try to add each item to a collection and ignore the errors when there's a duplicate key. Then you'll have a collection with a subset of unique values
Sub MakeUnique()
Dim vaData As Variant
Dim colUnique As Collection
Dim aOutput() As Variant
Dim i As Long
'Put the data in an array
vaData = Sheet1.Range("A1:A12").Value
'Create a new collection
Set colUnique = New Collection
'Loop through the data
For i = LBound(vaData, 1) To UBound(vaData, 1)
'Collections can't have duplicate keys, so try to
'add each item to the collection ignoring errors.
'Only unique items will be added
On Error Resume Next
colUnique.Add vaData(i, 1), CStr(vaData(i, 1))
On Error GoTo 0
Next i
'size an array to write out to the sheet
ReDim aOutput(1 To colUnique.Count, 1 To 1)
'Loop through the collection and fill the output array
For i = 1 To colUnique.Count
aOutput(i, 1) = colUnique.Item(i)
Next i
'Write the unique values to column B
Sheet1.Range("B1").Resize(UBound(aOutput, 1), UBound(aOutput, 2)).Value = aOutput
End Sub
For completeness, I'm posting the Scripting.Dictionary method: it's the commonest alternative to using a VBA.Collection and it avoids the need to rely on error-handling in normal operation.
A VBA Function using the Scripting.Dictionary Object to Return Unique Values from an Excel Range Containing Duplicates:
Option Explicit
' Author: Nigel Heffernan
' May 2012 http://excellerando.blogspot.com
' **** THIS CODE IS IN THE PUBLIC DOMAIN ****
'
' You are advised to segregate this code from
' any proprietary or commercially-confidential
' source code, and to label it clearly. If you
' fail do do so, there is a risk that you will
' impair your right to assert ownership of any
' intellectual property embedded in your work,
' or impair your employers or clients' ability
' to do so if the intellectual property rights
' in your work have been assigned to them.
'
Public Function UniqueValues(SourceData As Excel.Range, _
Optional Compare As VbCompareMethod = vbBinaryCompare _
) As Variant
Application.Volatile False
' Takes a range of values and returns a single-column array of unique items.
' The returned array is the expected data structure for Excel.Range.Value():
' a 1-based 2-Dimensional Array with dimensions 1 to RowCount, 1 to ColCount
' All values in the source are treated as text, and uniqueness is determined
' by case-sensitive comparison. To change this, set the Compare parameter to
' to 1, the value of the VbCompareMethod enumerated constant 'VbTextCompare'
' Error values in cells are returned as "#ERROR" with no further comparison.
' Empty or null cells are ignored: they do not appear in the returned array.
Dim i As Long, j As Long, k As Long
Dim oSubRange As Excel.Range
Dim arrSubRng As Variant
Dim arrOutput As Variant
Dim strKey As String
Dim arrKeys As Variant
Dim dicUnique As Object
' Note the late-binding as 'object' - best practice is to create a reference
' to the Windows Scripting Runtime: this allows you to declare dictUnique as
' Dim dictUnique As Scripting.Dictionary and instantiate it using the 'NEW'
' keyword instead of CreateObject, giving slightly better speed & stability.
If SourceData Is Nothing Then
Exit Function
End If
If IsEmpty(SourceData) Then
Exit Function
End If
Set dicUnique = CreateObject("Scripting.Dictionary")
dicUnique.CompareMode = Compare
For Each oSubRange In SourceData.Areas ' handles noncontiguous ranges
'Use Worksheetfunction.countA(oSubRange) > 0 to ignore empty ranges
If oSubRange.Cells.Count = 1 Then
ReDim arrSubRng(1 To 1, 1 To 1)
arrSubRng(1, 1) = oSubRange.Cells(1, 1).Value
Else
arrSubRng = oSubRange.Value
End If
For i = LBound(arrSubRng, 1) To UBound(arrSubRng, 1)
For j = LBound(arrSubRng, 2) To UBound(arrSubRng, 2)
If IsError(arrSubRng(i, j)) Then
dicUnique("#ERROR") = vbNullString
ElseIf IsEmpty(arrSubRng(i, j)) Then
' no action: empty cells are ignored
Else
' We use the error-tolerant behaviour of the Dictionary:
' If you query a key that doesn't exist, it adds the key
dicUnique(CStr(arrSubRng(i, j))) = vbNullString
End If
Next j
Next i
Erase arrSubRng
Next oSubRange
If dicUnique.Count = 0 Then
UniqueValues = Empty
Else
arrKeys = dicUnique.keys
dicUnique.RemoveAll
ReDim arrOutput(1 To UBound(arrKeys) + 1, 1 To 1)
For k = LBound(arrKeys) To UBound(arrKeys)
arrOutput(k + 1, 1) = arrKeys(k)
Next k
Erase arrKeys
UniqueValues = arrOutput
Erase arrOutput
End If
Set dicUnique = Nothing
End Function
A couple of notes:
This is code for any Excel range, not just the single-column range you asked for.This function tolerates cells with errors, which are difficult to handle in VBA.This isn't Reddit: you can read the comments, they are an aid to understanding and generally beneficial to your sanity.
I would use a simple array, go through all the letters and check if the letter you are on is in the array:
Sub unique_column()
Dim data() As Variant 'array that will store all of the unique letters
c = 1
Range("A1").Select
Do While ActiveCell.Value <> ""
ReDim Preserve data(1 To c) As Variant
If IsInArray(ActiveCell.Value, data()) = False Then 'we are on a new unique letter and will add it to the array
data(c) = ActiveCell.Value
c = c + 1
End If
ActiveCell.Offset(1, 0).Select
Loop
'now we can spit out the letters in the array into a new column
Range("B1").Value = "Unique letters:"
Dim x As Variant
Range("B2").Select
For Each x In data()
ActiveCell.Value = x
ActiveCell.Offset(1, 0).Select
Next x
Range("A1").Select
c = c - 1
killer = MsgBox("Processing complete!" & vbNewLine & c & "unique letters applied.", vbOKOnly)
End Sub
Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
IsInArray = (UBound(Filter(arr, stringToBeFound)) > -1)
End Function