Loop with multiple Ranges - vba

Im trying to write a code which determines whether certain cells are empty or not and then returns a set string.
To go in detail; I was hoping for the code to look into cell B2, determine if it is empty, then go to C2 and determine if it is non-empty. If both were correct in cell B2 it would then input "Correct" and move on in the range. However, my code doesnt seem to work because it just inputs "Correct" in every cell in the loop range.
I have posted my code below; any help would be much appreciated.
Sub Fill_Rows()
Dim X As Range
Let Y = Range("C2")
For Each X In Range("B2:B5000")
If X = "" And Y <> "" Then
X = "Correct"
End If
Y = Y + 1
Next X
End Sub

If you meant to check by each row like (B2 and C2) then (B3 and C3), then you could do it like this.
Sub Fill_Rows()
Dim iRow As Long
For iRow = 2 To 5000
If Cells(iRow, "B").Value = vbNullString And Cells(iRow, "C").Value <> vbNullString Then
Cells(iRow, "B").Value = "Correct"
End If
Next iRow
End Sub

Alternative
Added two solutions:
[1] an example code as close as possible to yours and
[2] an alternative using a datafield array to demonstrate a faster way for bigger data sets.
[1] Example Code close to yours
There is no need to use a second variable Y, all the more as apparently you left it undeclared, which always can cause issues (type mismatches, no range object etc.).
So always use Option Explicit in the declaration head of your code module to force yourself to declare all variable types you are using.
Now you can simply use an offset of 1 column to the existing cell to check the neighbouring cell, too.
Option Explicit ' declaration head of your code module (obliges to declare variables)
Sub Fill_RowsViaRangeLoop()
Dim X As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("MySheet") ' << replace with your sheet name
For Each X In ws.Range("B2:B5000")
If X = "" And X.Offset(0, 1) <> "" Then ' column offset 1 checks next cell in C
X = "Correct"
End If
Next X
End Sub
[2] Example Code using a datafield array
Looping through a bigger range isn't very fast, you can speed up your procedure by
assigning your range values to a variant datafield array v, loop through the received array items correcting found items in column 1 and write it back to sheet.
Option Explicit ' declaration head of your code module (obliges to declare variables)
Sub Fill_RowsViaArray()
Dim v As Variant, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("MySheet") ' << replace with your sheet name
' Assign values to a 2-dim array
v = ws.Range("B2:C5000") ' or better: v = ws.Range("B2:C5000").Value2
' Check criteria looping over all rows (=first array dimension)
For i = 1 To UBound(v) ' data field arrays are one-based, i.e. they start with 1
If v(i, 1) = vbNullString And v(i, 2) <> vbNullString Then v(i, 1) = "Correct"
Next i
' Write edited array back to original range (adapt the range size to the array boundaries in both dimensions)
ws.Range("B2").Resize(UBound(v, 1), UBound(v, 2)) = v
End Sub
Further Notes
It's good use to fully qualify your sheet or range references (see e.g. object variable ws)
Each array item is identified by a row and a column index.
As such a datafield array is one based (start indices are 1), the first item in row 1 and column 1 will be referred by v(1,1), in col 2 by v(1,2).
In order to count the number of row items you check the upper boundary of its first dimension) via UBound(v,1) or even shorter via Ubound(v)
In order to count the number of columns you check the upper boundary of its second dimension) via UBound(v,2) (here the argument 2 is necessary!)
A comparation using vbNullString can be preferred in coding to "" as it takes less memory (c.f. #PEH 's answer) .

Related

Executing a loop for a range of cells

This is a very basic question and I'm sure it has been answered but I can't seem to find it elsewhere. I have a portion of vba code that works fine for a single cell. However I want to expand it to work for a range of cells (all within the same column).
Basically its a goalseeking loops that changes a value in the "b" column until the value in the "w" column matches (comes within 99%) the value in the "x" column.
What works:
Sub Goalseeker()
Do Until Range("w32").Value / Range("x32").Value > 0.99
Range("b32").Value = Range("b32").Value - 1
Loop
End Sub
I want to extend this to work for rows 32 to 107.
What I've tried:
Edit: I've made adjustment based on the comments received and tweaked and few things before it worked. If anyone is interested in the process:
Option Explicit
Sub Goalseeker()
Dim i As Integer
Dim targetcell As Double
Dim outputcell As Double
Dim variablecell As Range
For i = 32 To 107
targetcell = Cells(i, "x")
outputcell = Cells(i, "w")
Set variablecell = Range("B" & i)
Do Until outputcell / targetcell > 0.99
variablecell = variablecell - 1
targetcell = Cells(i, "x")
outputcell = Cells(i, "w")
Loop
Next
End Sub
The bit I had to tweak was
Do Until outputcell / targetcell > 0.99
variablecell = variablecell - 1
targetcell = Cells(i, "x")
outputcell = Cells(i, "w")
Loop
Redefining (i apologize if that's the wrong term) targetcell and outputcell was necessary to prevent an infinite loop.
Thanks all. I will work on making this function for relative references instead of absolute.
Few problems here. Change your For i loop to the format For i = x to y not For i = x to i = y
You can refer to targetcell and outputcell as double but the variablecell needs to be a range. And if it's a range it needs Set
You should declare ALL your variables, as below.
And finally, you might want to put in a catch to get out of infinite looping (in case the target never reaches above 0.99 ?)
Sub Goalseeker()
Dim i As Integer
Dim targetcell As Double
Dim outputcell As Double
Dim variablecell As Range
For i = 32 To 107
targetcell = Cells(i, "x")
outputcell = Cells(i, "w")
Set variablecell = Range("B" & i)
Do Until outputcell / targetcell > 0.99
variablecell = variablecell - 1
Loop
Next
End Sub
Consider the following example table:
Use the code below to find the correct values in the "B" column (as shown) in order to minimize the error between the result (next column) and the goal (two columns over).
Option Explicit
Public Sub GoalSeekMyValues()
' Call GoalSeek with inputvalues "B2:B16", having the result
' at column offset 1, and the goal in column offset 2.
' Note that Range("B2").Resize(15, 1) = Range("B2:B16"),
' But I prefer the top cell and row count of this syntax.
GoalSeek Range("B2").Resize(15, 1), 1, 2
End Sub
Public Sub GoalSeek(ByVal variables As Range, ByVal result_offset As Long, ByVal goal_offset As Long)
Dim n As Long, i As Long, pct_error As Double, last_error As Double
'x is the input value (variable)
'y is the result
'g is the goal for y
Dim x As Double, y As Double, g As Double
' Read the number of rows in the input values
n = variables.Rows.Count
Dim r As Range
' Loop through the rows
For i = 1 To n
'Set a range reference at the i-th input cell
Set r = variables.Cells(i, 1)
' Read the value, the result and the goal
x = r.Value
y = r.Offset(0, result_offset).Value
g = r.Offset(0, goal_offset).Value
pct_error = Abs(y / g - 1)
Do
'Set the next value
r.Value = x - 1
' Read the result (assume goal doesn't change)
y = r.Offset(0, result_offset).Value
' Keep last error, and calculate new one
last_error = pct_error
pct_error = Abs(y / g - 1)
' If new error is more than last then exit the loop
' and keep the previous value (with less error).
If pct_error > last_error Then
' Keep last value
r.Value = x
Exit Do
End If
' read the input value
x = r.Value
' Assume inputs must be positive so end the loop
' on zero on negative numbers
Loop Until x <= 0
Next i
End Sub
Your code has lots of points of failure.
Your code might not ever reach a solution and excel will hang (until Ctrl-Break is pressed). I have a hard break when the inputs become zero or negative. Other problems require other ways to tell that there isn't a solution.
The first time the result comes within 1% of the solution might not produce the least error. I solve this by tracking the absolute value of the relative error. Only when the error starts increasing I terminate the loop. This assumes that decreasing the input by one unit will improve the solution (at least initially). If this is not the case the code will fail.
You use absolute referencing (like reading the 12th cell down and 4th across) and that is not very reusable style of programming. I always try to use relative referencing. I start from the top left referenced cell (in this case B2) and move down and right from there using the following methods:
Range("B2").Cells(5,1) - Reference 5th row and 1st column from B2.
Range("B2").Resize(15, 1) - Expand the range to include 15 rows and one column.
Range("B2).Cells(i,1).Offset(0, 3) - From the i-th row use column offset of 3 (meaning the 4th column in the table).
I suggest to use one of the common goal seeking methods (like bisection), or better yet, use the built-in goal seek function
example:
Range("B2").Cells(i,2).GoalSeek Goal:=Range("B2").Cells(i,3).Value, ChangingCell:=Range("B2").Cells(i,1)

Sum Values based on unique ID

Just started a new job. I'm automating a month-end report and I'm new at VBA. Been googling most of my issues with success, but I've finally run into a wall. In essence I'm downloading some data from SAP and from there I need to build a report.
My question is: How to do a sumif function using loops in VBA?
Data pull:
Sheet1 contains a product code and purchase amounts (columns A & B) respectively. One product code can have several purchases (several rows with the same product code).
Steps so far:
I arranged the data sheet1 to be in ascending order.
Copied unique values for the product codes onto another sheet (sheet2). So Sheet2 has a list of all the products (in ascending order).
I want to get the sum of all purchases in sheet2 column B (per product code). I know how to do this using formulas, but I need to automate this as much as possible. (+ I'm genuinely interested in figuring this out)
This is what I did in VBA so far:
Sub Macro_test()
Dim tb As Worksheet
Dim tb2 As Worksheet
Dim x As Integer
Dim y As Integer
Dim lrow As Long
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
lrow = tb.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lrow
For y = 2 To lrow
If tb2.Cells(x, 1).Value = tb.Cells(y, 1).Value Then
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
End If
Next y
Next x
End Sub
If i'm not mistaken, for each product_code in sheet2 col A, I'm looping through all the product codes in sheet1 and getting back the LAST value it finds, instead of the sum of all values... I understand why it doesn't work, I just don't know how to fix it.
Any help would be much appreciated. Thanks!
This statement overwrites the value of tb2.Cells(x, 2).Value at each iteration:
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
Instead, I think you need to keep adding to it:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + tb.Cells(y, 2).Value
But I don't like the looks of your double-loop which uses only one lrow variable to represent the "last row" on the two different worksheets, that could be causing some issues.
Or, in your loop do something like this which I think will avoid the duplicate sum. Still, assumes the second worksheet doesn't initially have any value in
' Base our lRow on Sheet2, we don't care how many rows in Sheet1.
lrow = tb2.Cells(tb2.Rows.Count, 1).End(xlUp).Row
Dim cl as Range
Set cl = tb.Cells(2,1) 'Our initial cell value / ID
For x = 2 to lRow '## Look the rows on Sheet 2
'## Check if the cell on Sheet1 == cell on Sheet2
While cl.Value = tb2.Cells(x,1).Value
'## Add cl.Value t- the tb2 cell:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + cl.Offset(0,1).Value
Set cl = cl.Offset(1) '## Reassign to the next Row
Wend
Next
But it would be better to omit the double-loop and simply use VBA to do 1 of the following:
1. Insert The Formula:
(See Scott Holtzman's answer).
This approach is better for lots of reasons, not the least of which is that the WorksheetFunction is optimized already, so it should arguably perform better though on a small dataset the difference in runtime will be negligible. The other reason is that it's stupid to reinvent the wheel unless you have a very good justification for doing so, so in this case, why write your own version of code that accomplishes what the built-in SumIf already does and is specifically designed to do?
This approach is also ideal if the reference data may change, as the cell formulas will automatically recalculate based on the data in Sheet1.
2. Evaluate the formula & replace with values only:
If you prefer not to retain the formula, then a simple Value assignment can remove the formula but retain the results:
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
.Value = .Value 'This line gets rid of the formula but retains the values
End With
Use this approach if you will be removing Sheet1, as removing the referents will break the formula on Sheet2, or if you otherwise want the Sheet2 to be a "snapshot" instead of a dynamic summation.
If you really need this automated, take advantage of VBA to place the formula for you. It's very quick and easy using R1C1 notation.
Complete code (tested):
Dim tb As Worksheet
Dim tb2 As Worksheet
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
Dim lrow As Long
lrow = tb.Cells(tb.Rows.Count, 1).End(xlUp).Row
tb.Range("A2:A" & lrow).Copy tb2.Range("A2")
With tb2
.Range("A2").CurrentRegion.RemoveDuplicates 1
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
End With
End With
Note that with R1C1 notation the C and R are not referring to column or row letters . Rather they are the column and row offsets from the place where the formula is stored on the specific worksheet. In this case Sheet!C[-1] refers to the entire A column of sheet one, since the formula is entered into column B of sheet 2.
I wrote a neat little algorithm (if you can call it that) that does what you want them spits out grouped by totals into another sheet. Basically it loops through the first section to get unique names/labels and stores them into an array. Then it iterates through that array and adds up values if the current iteration matches what the current iteration of the nested loop position.
Private Sub that()
Dim this As Variant
Dim that(9, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("Sheet4").UsedRange
rowC = ThisWorkbook.Sheets("Sheet4").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("Sheet4").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue + this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("sheet5").Range(ThisWorkbook.Sheets("Sheet5").Cells(1, 1), ThisWorkbook.Sheets("Sheet5").Cells(rowC, colC)).Value2 = that
End Sub
Yay arrays

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.

Loopy Loop through Range in Excel VBA

I am looping through a range in Excel VBA. I have an IF-Then that checks to see if the a cell contains a number. I then want the address of the cell that contains the number. The problem is my code returns the first cell with a number over and over.
For Each Row in Room.Rows
If IsNumber(Row.Cells(,1)) then
x = (Row.cells(,1))
End If
Next Row
For Each Row in Room.Rows
If WorksheetFunction.IsNumber(range("A" & Row.row)) then
x = range("A" & Row.row).address
// do stuff with x
End If
Next Row
1) don't use variable names that will confuse people (row)
2) in the for each loop example, you don't need to add the .rows ,
considering your named variable 'row' is a row type.
3) Declare all your variables
4) i changed the code with an other approach :
Dim R as Long
Dim Rg as Range
Dim x as String
For R=1 to Room.rows.count
set Rg= Room.cells(r,1)
If IsNumeric(Rg) then
x = Rg.address
// do stuff with x
End If
Next R
set rg= nothing

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