i have programmed a procedure to find all values of a list and store them in a collection. There are identical values but each value only should be stored once.
Here is my vba code:
For intRow = intStart To ActiveSheet.Cells(Rows.count, 1).End(xlUp).Row
k = 1
Do
If k > colData.count Then
colData.Add Trim(Cells(intRow, intClmn).Value)
Exit Do
ElseIf Trim(Cells(intRow, intClmn)) = colData.Item(k) Then
Exit Do
End If
k = k + 1
Loop
Next i
I wonder if there is a more efficient way to get those values though. Do you know a more efficient way to collect values of a list?
If I've understood then I would record copying and pasting the column to a blank worksheet, and using the Remove Duplicates feature on this area to result in a column of distinct values that you can iterate.
As the new (temporary) worksheet is blank other than the retained values, you could use UsedRange to iterate all its cells:
For rng In Sheets("TempSht").UsedRange
Next rng
or again use End(xlUp) (or xlDown).
Could even get the entire range into an array if appropriate:
Dim arr As Variant
arr = WorksheetFunction.Transpose(Range("A1:A3"))
I ommited declaration of intStart and intClmn as well as calculating their values.
You can use Dictionary object and operate with an array instead of cells.
You need to add a reference in order to use early binding, a great answer is already here. You need Microsoft Scripting Runtime reference.
Dim vArr(), i As Long, j As Long, DataRange As Range
'Dim intStart As Long, intClmn As Long
'intStart = 1: intClmn = 7
' Declaring and creating a dictionary (choose one and wisely)
'--------------------------------------------------------------
' Late binding
Dim iDict As Object
Set iDict = CreateObject("Scripting.Dictionary")
' Early binding (preferable, you need to enable reference)
'Dim iDict As Scripting.Dictionary
'Set iDict = New Scripting.Dictionary
'--------------------------------------------------------------
' Define range of your data (may vary, modify so it suits your needs)
With ActiveSheet
Set DataRange = .Range(.Cells(intStart, 1), _
.Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, intClmn))
End With
' Populate an array with trimmed values
' I'm not sure how productive it is comparing to calling Trim in a loop so..
' You're free to test it
vArr = Evaluate("IF(ROW(), TRIM(" & DataRange.Address & "))")
' Loop through array
For i = LBound(vArr, 1) To UBound(vArr, 1)
For j = LBound(vArr, 2) To UBound(vArr, 2)
' Add an item with the key of vArr(i, j),
' otherwise change an existing item with this key to vArr(i, j)
iDict(vArr(i, j)) = vArr(i, j)
Next j
Next i
Related
I am working on a report and trying to output my data like this
Input:
Output
I am thinking of using a dictionary with each key has multiple value of Items&their but i don't know how to implement.
Using a dictionary would not work for your chart example. A dictionary is used to hold ONLY TWO string values using a hashtable. An example of using a dictionary properly is using the two words "hello" and "a polite greeting to another human". The first string is for the word and the second is the definition of the word, just like a regular dictionary.
I would provide you with two better options. You could create a 2D array which holds all your values, but you would need to output the labels separately from the values. You could also create a file which holds the labels and the values for your chart.
If you need more help, please provide more information on what you are trying to do with the chart displayed. An array is better for calculations but a file is better for storing the values and displaying the chart.
Second answer would be to use a dictionary of dictionaries. Again input data is
With the following code
Sub DemoDictOfDict()
Dim rg As Range, rgHdr As Range
Dim dict As Dictionary
Dim sngDict As Dictionary
Dim wkb As Workbook, wks As Worksheet
Set wkb = ActiveWorkbook
Set wks = wkb.ActiveSheet
Set rg = wks.Range("A1").CurrentRegion
' Retrieving the header line from the data
Set rgHdr = rg.Rows(1).Offset(, 1).Resize(, rg.Columns.Count - 1)
Dim vHdr As Variant
vHdr = rgHdr.Value
Dim sngRow As Range
Dim sngCell As Range
Dim vdat As Variant
Dim k As Long
' Creating the dictionary which will be used
' to hold the dictionaries with the data
Set dict = New Dictionary
' Looping through the rows of the data
' as we are not using the listobject one has to use offset and resizte
For Each sngRow In rg.Offset(1).Resize(rg.Rows.Count - 1).Rows
' getting the number for different columns
' again listobject not used, so working with resizte and offset
vdat = sngRow.Offset(, 1).Resize(, sngRow.Columns.Count - 1)
' Creating the dictionary containing the numbers
Set sngDict = New Dictionary
For k = LBound(vHdr, 2) To UBound(vHdr, 2)
' Adding the values to the "inner" dictionary
sngDict.Add vHdr(1, k), vdat(1, k)
Next k
' Adding the dictionary to the dictionary
Set dict(sngRow.Cells(1, 1).Value) = sngDict
Next
' output to immediate windows
Dim outName As String, vDict As Dictionary
Dim key As Variant, i As Long
For i = 0 To dict.Count - 1
outName = dict.Keys(i)
Set vDict = dict.Items(i)
Debug.Print outName
For Each key In vDict.Keys
Debug.Print key, vDict(key)
Next
Next i
End Sub
you get the following output in the immediate window
First answer as said in one of my comments you could use Power Query to unpivot the data. As example data I took data like this
After unpivoting the data with PowerQuery (goto Data then From Table/Range, select the columns with Apple, Orange etc. in the Power Query Editor, select the tab Transform and there Unpivot columns) one gets
Then you pivot the data again and you get
Unless you're going to do something else with the collected data then there's no need for any intermediate data structure:
Dim data, r As Long, c As Long
data = ActiveSheet.Range("A3:D5").Value
For r = 2 To UBound(data, 1)
Debug.Print data(r, 1)
For c = 2 To UBound(data, 2)
Debug.Print data(1, c) & " " & data(r, c)
Next c
Debug.Print "Checked."
Next r
The location of the data should be the same as the picture to work.
Sub test()
Dim vDB As Variant
Dim vR() As Variant
Dim i As Long, r As Long, n As Long
Dim c As Integer, j As Integer
vDB = Range("a3").CurrentRegion
r = UBound(vDB, 1)
c = UBound(vDB, 2)
For i = 3 To r
n = n + 1
ReDim Preserve vR(1 To n)
vR(n) = vDB(i, 1)
For j = 2 To c
n = n + 1
ReDim Preserve vR(1 To n)
If vDB(i, j) = "" Then
vR(n) = "Checked"
Else
vR(n) = vDB(2, j) & Space(1) & vDB(i, j)
End If
Next j
Next i
Sheets.Add
Range("a1").Resize(n) = WorksheetFunction.Transpose(vR)
End Sub
Result Sheet
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
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
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)
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