I've got a worksheet with a lot of tables in them and I'm just starting to use tables because they seem pretty handy. But I've never manipulated content in an Excel table before. And these tables are basically lists of columns with Firstname and Lastname. Based on the values on these columns, I want to generate a username. But I'm trying to write a generic Sub that takes arguments, such as worksheet and name of the table.
Previously I've done this when the data has not been in a table:
Cells(2, 2).Select
Do
strFirstName = ActiveCell.Value
strLastName = ActiveCell.Offset(0, 2).Value
strFirstName = Left(strFirstName, 1)
strUserName = strFirstName & strLastName
strUserName = LCase(strUserName)
ActiveCell.Offset(0, 5).Value = strUserName
ActiveCell.Offset(1, 0).Select
Loop Until IsEmpty(ActiveCell)
And now I'm trying to do the exact same thing, only with data from a Table. Any ideas? I've added a watch for "ActiveSheet" to see if I can find the tables, and they seem to be in ActiveSheet.ListObjects, but I couldn't see any .Select option there. Perhaps I don't need to select the Table in order to manipulate it's content?
When looping over a range (whether in a table or in a range) it is usually faster to copy the data to a variant array, manipulate that array, and then copy the result back to the sheet.
Sub zz()
Dim oUsers As ListObject
Dim v As Variant
Dim vUserName() As Variant
Dim i As Long
Dim colFirst As Long
Dim colLast As Long
Dim colUser As Long
Set oUsers = ActiveSheet.ListObjects(1)
colFirst = oUsers.ListColumns("FirstName").Index
colLast = oUsers.ListColumns("LastName").Index
colUser = oUsers.ListColumns("UserName").Index
v = oUsers.DataBodyRange
ReDim vUserName(1 To UBound(v, 1), 1 To 1)
For i = 1 To UBound(v, 1)
vUserName(i, 1) = LCase(Left(v(i, colFirst), 1) & v(i, colLast))
Next
oUsers.ListColumns("UserName").DataBodyRange = vUserName
End Sub
If you really want to loop over the range itself:
For i = 1 To oUsers.ListRows.Count
oUsers.ListColumns("UserName").DataBodyRange.Rows(i) = LCase(Left( _
oUsers.ListColumns("FirstName").DataBodyRange.Rows(i), 1) & _
oUsers.ListColumns("LastName").DataBodyRange.Rows(i))
Next
For this situation you could also just use a formula in the UserName column itself, with no vba required
=LOWER(LEFT([#FirstName],1)&[#LastName])
EDIT
Sorry, don't know of a Formula way to remove any of a list of characters from a string. You might have to revert to vba for this. Here's a user defined function to do it. Your formula will become
=DeleteChars([#UserName],{"$","#"})
To Delete the characters replace {"$","#"} with a array list of characters you want to remove (you can make the list as long as you need)
To replace the characters use {"$","#";"X","X"} where the list up to the ; is the old characters, after the ; the new. Just make sure the listsa are the same length.
UDF code:
Function DeleteChars(r1 As Range, ParamArray c() As Variant) As Variant
Dim i As Long
Dim s As String
s = r1
If UBound(c(0), 1) = 1 Then
For i = LBound(c(0), 2) To UBound(c(0), 2)
s = Replace(s, c(0)(1, i), "")
Next
Else
For i = LBound(c(0), 2) To UBound(c(0), 2)
s = Replace(s, c(0)(1, i), c(0)(2, i))
Next
End If
DeleteChars = s
End Function
Related
I want my code to go through a list of cells containing names and split them up into the cells next to the original. I have some basic code to do the first bit, but I'm struggling to get it to cycle through the rest of my list, and also outputting it next to the original rather than in A1 as it does currently. I presume it's an issue with the 'Cell' part of the code but I can't quite fix it.
Sub NameSplit()
Dim txt As String
Dim i As Integer
Dim FullName As Variant
Dim x As String, cell As Range
txt = ActiveCell.Value
FullName = Split(txt, " ")
For i = 0 To UBound(FullName)
Cells(1, i + 1).Value = FullName(i)
Next i
End Sub
Use a For Each loop on the range of name values. In this case, I just assumed they were in the first column but you can adjust accordingly:
Sub NameSplit()
Dim txt As String
Dim i As Integer
Dim FullName As Variant
Dim x As String, cell As Range
For Each cell In ActiveSheet.Range(Cells(1,1),Cells(ActiveSheet.UsedRange.Count,1))
txt = cell.Value
FullName = Split(txt, " ")
For i = 0 To UBound(FullName)
cell.offset(0,i + 1).Value = FullName(i)
Next i
Next cell
End Sub
Make sure you are not trying to Split a blank cell and write all of the values in at once rather than nest a second For ... Next Statement.
Sub NameSplit()
Dim var As Variant
Dim rw As Long
With Worksheets("Sheet1") '<~~ you should know what worksheet you are on!!!!
'from row 2 to the last row in column A
For rw = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
'check to make the cell is not blank
If CBool(Len(.Cells(rw, "A").Value2)) Then
'split on a space (e.g. Chr(32))
var = Split(.Cells(rw, "A").Value2, Chr(32))
'resize the target and stuff the pieces in
.Cells(rw, "B").Resize(1, UBound(var) + 1) = var
End If
Next rw
End With
End Sub
If you are simply splitting on a space, have you considered a Range.TextToColumns method?
Sub NameSplit2()
Dim var As Variant
Dim rw As Long
'disable overwrite warning
Application.DisplayAlerts = False
With Worksheets("Sheet1") '<~~ you should know what worksheet you are on!!!!
'from row 2 to the last row in column A
With .Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
'Text-to-Columns with space delimiter
.TextToColumns Destination:=.Cells(1, 2), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, _
Tab:=False, Semicolon:=False, Comma:=False, Other:=False, _
Space:=True
End With
End With
Application.DisplayAlerts = True
End Sub
One method is to combine a do loop with a for loop.
Do loops are a great way to iterate over items, when you are not sure at the outset how many items there are. In this case you may have more names during one execution than the next.
For loops are handy when you know in advance how many items you will be looping over. In this case we know at the start of the loop how many elements are in our names array.
The code below starts with the active cell and works its way down, until it finds an empty cell.
Sub SplitName()
' Splits names into columns, using space as a delimitor.
' Starts from the active cell.
Dim names As Variant ' Array. Holds names extracted from active cell.
Dim c As Integer ' Counter. Used to loop over returned names.
' Keeps going until the active cell is empty.
Do Until ActiveCell.Value = vbNullString
names = Split(ActiveCell.Value, Space(1))
' Write each found name part into a seperate column.
For c = LBound(names) To UBound(names)
' Extract element to an offset of active cell.
ActiveCell.Offset(0, c + 1).Value = names(c)
Next
ActiveCell.Offset(1, 0).Select ' Move to next row.
DoEvents ' Prevents Excel from appearing frozen when running over a large number of items.
Loop
End Sub
There are several ways you could improve this proceedure.
As a general rule automation is more robust when it avoids objects like ActiveCell. This is because the user could move the active cell while your code is executing. You could refactor this procedure to accept a source range as a parameter. You could then build another sub that calculates the source range and passes it to this sub for processing. That would improve the reusability of SplitName.
You could also look into Excels Text to Columns method. This could potentially produce the desired result using fewer lines of code, which is always good.
Text to Columns would be a great way to do this if you can. If not here is a way to do it using arrays and a dictionary. The advantage of this is that all of the cells are read in one go and then operated on in memory before writing back the results.
Sub SplitCells()
Dim i As Long
Dim temp() As Variant
Dim dict As Variant
' Create a dictionary
Set dict = CreateObject("scripting.dictionary")
' set temp array to values to loop through
With Sheet1
'Declare your range to loop through
temp = .Range(.Cells(1, 1), .Cells(.Cells(.Rows.Count, 1).End(xlUp).Row, 1))
End With
' Split the values in the array and add to dictionary
For i = LBound(temp) To UBound(temp)
dict.Add i, Split(temp(i, 1), " ")
Next i
' Print dictionary results
With Sheet1.Cells(1, 2)
For Each Key In dict.keys
.Range(.Offset(Key - 1, 0), .Offset(Key - 1, UBound(dict.Item(Key)))) = dict.Item(Key)
Next Key
End With
End Sub
Output:
I am trying to order, from most senior downwards, a list of employees based on who their manager is. The tricky part is having all senior persons employees listed before moving on to the next person of the same level. For example see this image:
All people reporting to Dick, either directly or indirectly, are listed below him before moving on to Peter - the next person at his level.
So if the table looked like this:
Is there a VBA that will reorder the table to look like the first example? The table to be reordered may not look like this - it would have to work regardless of who it was wrongly ordered.
Note: The order of people at the same level is unimportant...
Thanks for your help.
I love stuff like this. Create an Excel sheet with two tabs, and name one "Input" and one "Output". Copy your example table into the "Input" then just the headers into "Output". Then plug the code below in. This should show you the idea, which is basic recursion. It's fairly horrible to do in VBA, it would be a lot prettier in C.
Option Explicit
Dim RawName() As Variant
Dim RawManager() As Variant
Dim RawLevel() As Variant
Dim TopNode As Integer
Sub FncSortHierarchy()
TopNode = FncPopulateRawHierarchy("A", "B", "C")
If TopNode <> 0 Then
Sheets("Output").Select
FncWritePerson (TopNode)
FncGetSubordinates (TopNode)
End If
End Sub
Private Function FncGetSubordinates(indexManager As Integer) As Integer
Dim i As Integer
Dim name As String
Dim manager As String
manager = RawName(indexManager)
For i = 1 To UBound(RawName)
If RawManager(i) = manager Then
name = RawName(i)
FncWritePerson (i)
FncGetSubordinates (i)
End If
Next i
End Function
Private Function FncWritePerson(index As Integer)
Dim nextRow As Integer
nextRow = ActiveSheet.UsedRange.Rows.Count + 1
Range("A" & nextRow) = RawName(index)
Range("B" & nextRow) = RawManager(index)
Range("C" & nextRow) = RawLevel(index)
End Function
Private Function FncPopulateRawHierarchy(nameCol As String, managerCol As String, levelCol As String) As Integer
Dim i As Integer
Sheets("Input").Select
ReDim RawName(ActiveSheet.UsedRange.Rows.Count)
ReDim RawManager(ActiveSheet.UsedRange.Rows.Count)
ReDim RawLevel(ActiveSheet.UsedRange.Rows.Count)
For i = 2 To ActiveSheet.UsedRange.Rows.Count
RawName(i - 1) = Range(nameCol & i).Value
RawManager(i - 1) = Range(managerCol & i).Value
RawLevel(i - 1) = Range(levelCol & i).Value
If RawManager(i - 1) = "N/A" Then FncPopulateRawHierarchy = i - 1
Next i
End Function
I am trying to write a macro in Excel to calculate the standard deviation of same text in column A taking the values from column B and giving the results in column C:
I did it manually by putting the equation=STDEV.S(A2;A3;A4;A16)for "aaa". But I need to do this automatically because I am doing another calculation and procedures which are completing by macros. Here is my code:
Option Explicit
Sub Main()
CollectArray "A", "D"
DoSum "D", "E", "A", "B"
End Sub
' collect array from a specific column and print it to a new one without duplicates
' params:
' fromColumn - this is the column you need to remove duplicates from
' toColumn - this will reprint the array without the duplicates
Sub CollectArray(fromColumn As String, toColumn As String)
ReDim arr(0) As String
Dim i As Long
For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
arr(UBound(arr)) = Range(fromColumn & i)
ReDim Preserve arr(UBound(arr) + 1)
Next i
ReDim Preserve arr(UBound(arr) - 1)
RemoveDuplicate arr
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
For i = LBound(arr) To UBound(arr)
Range(toColumn & i + 1) = arr(i)
Next i
End Sub
' sums up values from one column against the other column
' params:
' fromColumn - this is the column with string to match against
' toColumn - this is where the SUM will be printed to
' originalColumn - this is the original column including duplicate
' valueColumn - this is the column with the values to sum
Private Sub DoSum(fromColumn As String, toColumn As String, originalColumn As String, valueColumn As String)
Range(toColumn & "1:" & toColumn & Range(toColumn & Rows.Count).End(xlUp).Row).ClearContents
Dim i As Long
For i = 1 To Range(fromColumn & Rows.Count).End(xlUp).Row
Range(toColumn & i) = WorksheetFunction.SumIf(Range(originalColumn & ":" & originalColumn), Range(fromColumn & i), Range(valueColumn & ":" & valueColumn))
Next i
End Sub
Private Sub RemoveDuplicate(ByRef StringArray() As String)
Dim lowBound$, UpBound&, A&, B&, cur&, tempArray() As String
If (Not StringArray) = True Then Exit Sub
lowBound = LBound(StringArray): UpBound = UBound(StringArray)
ReDim tempArray(lowBound To UpBound)
cur = lowBound: tempArray(cur) = StringArray(lowBound)
For A = lowBound + 1 To UpBound
For B = lowBound To cur
If LenB(tempArray(B)) = LenB(StringArray(A)) Then
If InStrB(1, StringArray(A), tempArray(B), vbBinaryCompare) = 1 Then Exit For
End If
Next B
If B > cur Then cur = B
tempArray(cur) = StringArray(A)
Next A
ReDim Preserve tempArray(lowBound To cur): StringArray = tempArray
End Sub
It would be nice if someone could please give me an idea or solution. The above code is for calculating the summation of same text values. Is there any way to modify my code to calculate the standard deviation?
I went in a different direction and provided a pseudo-STDEV.S.IF to be used much like the COUNTIF or AVERAGEIF function.
Function STDEV_S_IF(rAs As Range, rA As Range, rBs As Range)
Dim a As Long, sFRM As String
sFRM = "STDEV.s("
Set rBs = rBs(1).Resize(rAs.Rows.Count, 1)
For a = 1 To rAs.Rows.Count
If rAs(a).Value2 = rA.Value2 Then
sFRM = sFRM & rBs(a).Value2 & Chr(44)
End If
Next a
sFRM = Left(sFRM, Len(sFRM) - 1) & Chr(41)
STDEV_S_IF = Application.Evaluate(sFRM)
End Function
Syntax: STDEV_S_IF(<criteria range>, <criteria>, <stdev.s values>)
In your sample, the formula in C2 would be,
=STDEV_S_IF(A$2:A$20, A2, B$2:B$20)
Fill down as necessary.
Here is a formula and VBA route that gives you the STDEV.S for each set of items.
Picture shows the various ranges and results. My input is the same as yours, but I accidentally sorted it at one point so they don't line up.
Some notes
ARRAY is the actual answer you want. NON-ARRAY showing for later.
I included the PivotTable to test the accuracy of the method.
VBA is the same answer as ARRAY calculated as a UDF which could be used elsewhere in your VBA.
Formula in cell D3 is an array formula entered with CTRL+SHIFT+ENTER. That same formula is in E3 without the array entry. Both have been copied down to the end of the data.
=STDEV.S(IF(B3=$B$3:$B$21,$C$3:$C$21))
Since it seems you need a VBA version of this, you can use the same formula in VBA and just wrap it in Application.Evaluate. This is pretty much how #Jeeped gets an answer, converting the range to values which meet the criteria.
VBA Code uses Evaluate to process a formula string built from the ranges given as input.
Public Function STDEV_S_IF(rng_criteria As Range, rng_criterion As Range, rng_values As Range) As Variant
Dim str_frm As String
'formula to reproduce
'=STDEV.S(IF(B3=$B$3:$B$21,$C$3:$C$21))
str_frm = "STDEV.S(IF(" & _
rng_criterion.Address & "=" & _
rng_criteria.Address & "," & _
rng_values.Address & "))"
'if you have more than one sheet, be sure it evalutes in the right context
'or add the sheet name to the references above
'single sheet works fine with just Application.Evaluate
'STDEV_S_IF = Application.Evaluate(str_frm)
STDEV_S_IF = Sheets("Sheet2").Evaluate(str_frm)
End Function
The formula in F3 is the VBA UDF of the same formula as above, it is entered as a normal formula (although entering as an array does not affect anything) and is copied down to the end.
=STDEV_S_IF($B$3:$B$21,B3,$C$3:$C$21)
It is worth noting that .Evaluate processes this correctly as an array formula. You can compare this against the NON-ARRAY column included in the output. I am not certain how Excel knows to treat it this way. There was previously a fairly extended conversion about how Evaluate process array formulas and determines the output. This is tangentially related to that conversation.
And for completeness, here is the test of the Sub side of things. I am running this code in a module with a sheet other than Sheet2 active. This emphasizes the ability of using Sheets("Sheets2").Evaluate for a multi-sheet workbook since my Range call is technically misqualified. Console output is included.
Sub test()
Debug.Print STDEV_S_IF(Range("B3:B21"), Range("B3"), Range("C3:C21"))
'correctly returns 206.301357242263
End Sub
I was having some trouble with a macro I have been writing. I am trying to find a match in column A and column D. When I detect a match I want to copy the adjacent cells of each I.E copy the contents of B of the line of the first match to E where the match occurs in D. Whenever I do this I never get the right copy. It will copy the values that match but put them in the completely wrong space. I only encounter a problem when the order is mixed up or there is a white space. Any suggestions would be helpful.
Thanks
Nick.
Note: In this version of my code I was using input boxes to pick what two columns of data the user wants to compare and the one he wants to copy from and paste too. It should not make a big difference.
Sub Copy()
Dim column1 As String
Dim column2 As String
Dim from As String
Dim too As String
numrows = Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
'MsgBox numrows
column1 = InputBox("which column do you want to select from")
column2 = InputBox("which column do you want to compare to ")
from = InputBox("which column do you want to copy data from")
too = InputBox("which column do you want to copy data to")
Dim lngLastRow As Long
Dim lngLoopCtr As Long
Dim i As Long
Dim j As Long
Dim value As String
lngLastRow = Range(column1 & Rows.Count).End(xlUp).Row
lngLastRow2 = Range(column2 & Rows.Count).End(xlUp).Row
'lngLastRow = Sheet1.Range("A1").Offset(Sheet1.Rows.Count - 1, 0).End(xlUp).Row
Dim temp As String
For i = 1 To lngLastRow Step 1
temp = Cells(i, column1).value
value = Cells(i, from).value
'MsgBox "temp"
'MsgBox (temp)
If Cells(i, column1).value <> "" Then
For j = 1 To lngLastRow2 Step 1
' MsgBox "cell"
' MsgBox (Cells(j, column2).value)
If Cells(j, column2).value = "" Then
Cells(j, column2).Offset(1, 0).Select
End If
If Cells(j, column2).value <> "" Then
If temp = Cells(j, column2).value Then
'MsgBox "equal"
'MsgBox "i"
'MsgBox i
'MsgBox "j"
'MsgBox j
'value = Cells(j, from).value
'MsgBox Cells(i, too).value
'Cells(i, too).value = Cells(j, from).value
'Dim num As Integer
'On Error Resume Next
'num = Application.WorksheetFunction.VLookup(temp, Sheet1.Range("A0:M13"), 3, False)
Cells(i, too).value = Cells(j, from).value
'MsgBox j
' MsgBox (Cells(i, column1).value)
' MsgBox "="
' MsgBox (Cells(j, column2).value)
End If
End If
Next j
End If
Next i
End Sub
I have studied your text and your macro and think the macro below does what you want.
If this macro does what you want, your problem was caused by your use of meaningless variable names such as: column1, column2, i and j. This meant you did not notice you were using the wrong variables in the statement that copied values.
I have renamed all your variables. I am not asking you to like my naming convention but I am recommending you have a naming convention. I can look at macros I wrote years ago and know what all the variables are because I developed my convention in my early days of VBA programming and have used it every since. This makes my life much easier when I need to update old macros.
I have added Option Explicit at the top of the module. Without this statement, a misspelt variable name becomes a declaration:
Dim Count As Long
Lots of statements
Count = Conut + 1
This causes Conut to be declared with a value of zero. Such errors can be a nightmare to find.
I have used a With Statement to make explicit which worksheet I am using.
You checked both cells to not be empty. I only check the first because it is not necessary to check the second since, if the second is empty, it will not match the first.
Your code did not stop working down the Compare column if it found a match so my code does the same. This is correct if values can repeat in the Compare column. If they cannot repeat, you may wish to add Exit For to exit the inner loop after a match has been processed.
I believe the above explains all the changes I hve made.
Option Explicit
Sub Copy()
Dim ColCompare As String
Dim ColCopyFrom As String
Dim ColCopyTo As String
Dim ColSelect As String
Dim RowCrntCompare As Long
Dim RowCrntSelect As Long
Dim RowLastColCompare As Long
Dim RowLastColSelect As Long
Dim SelectValue As String
With Sheet1
ColSelect = InputBox("which column do you want to select ColCopyFrom")
ColCompare = InputBox("which column do you want to compare to ")
ColCopyFrom = InputBox("which column do you want to copy data ColCopyFrom")
ColCopyTo = InputBox("which column do you want to copy data to")
RowLastColSelect = .Range(ColSelect & .Rows.Count).End(xlUp).Row
RowLastColCompare = .Range(ColCompare & .Rows.Count).End(xlUp).Row
For RowCrntSelect = 1 To RowLastColSelect Step 1
SelectValue = .Cells(RowCrntSelect, ColSelect).value
If SelectValue <> "" Then
For RowCrntCompare = 1 To RowLastColCompare Step 1
If SelectValue = Cells(RowCrntCompare, ColCompare).value Then
.Cells(RowCrntCompare, ColCopyTo).value = _
.Cells(RowCrntSelect, ColCopyFrom).value
End If
Next RowCrntCompare
End If
Next RowCrntSelect
End With
End Sub
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