I need to list all values that have a specific criteria in other columns as shown
I have the following:
Sub arytest()
Dim ary()
Dim note2()
Dim lastrow As Long
Dim i As Long
Dim k As Long
Dim eleAry, x
'Number of rows in my data file
lastrow = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
'The maximum length of my array
ReDim ary(1 To lastrow)
k = 1
For i = 1 To lastrow
If Cells(i, 2) Like "*Note 2*" _ ' Criterias that needs to be fullfilled
And Cells(i, 1) Like "Actuals" _
And Cells(i, 4) Like "Digitale Brugere" Then
ary(k) = Cells(i, 3)
k = k + 1
End If
Next i
End Sub
This code lists all values I need. However some of them are present multiple times. How can I remove duplicates?
Here is another way, so you won't need to remove duplicates later, using Scripting Dictionary (you need to check the Microsoft Scripting Runtime on the libraries for this to work)
Sub arytest()
Dim ary()
Dim note2() 'unsued
Dim lastrow As Long
Dim i As Long
Dim k As Long
Dim eleAry, x 'unused
Dim DictDuplicates As Scripting.Dictionary
Set DictDuplicates = New Scripting.Dictionary
'Number of rows in my data file
lastrow = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row
'The maximum length of my array
ReDim ary(1 To lastrow)
k = 1
For i = 1 To lastrow
' Criterias that needs to be fullfilled
If Cells(i, 2) Like "*Note 2*" _
And Cells(i, 1) Like "Actuals" _
And Cells(i, 4) Like "Digitale Brugere" Then
If Not DictDuplicates.Exists(Cells(i, 3).Value) Then 'check if the value is already on the array
ary(k) = Cells(i, 3)
DictDuplicates.Add Cells(i, 3).Value, i 'if it does not exists, add it to the dictionary
End If
k = k + 1
End If
Next i
End Sub
I've also seen some variables unused on your code, or at least what you posted.
PS: when using the Likeoperator you should use the wildcards* or ?, without them is the same as if you were using the = operator.
Related
Trying to figure out the code to make an array of all unique values in a column.
So like say from C3:C30 I want an array named divisionNames of all unique values in that range. I intend to use the array later in the code. Trying to figure out a minimalist way of doing it so I don't add like 60 more lines of code to the macro.
Would be very appreciative of any suggestions
UPDATE:
Gary's Student's response below did the trick for what I needed, but I very much appreciate the help everyone gave. Thank you. Also as a side note I am now realizing I should have added that I am using Office 365. To be honest I didn't realize it made that much of a difference, but I will remember that for future reference and again thank you for all of the help
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
End With
End Sub
With Excel 365:
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
End With
End Sub
EDIT#1:
This version will sort the results and put the data in column D:
Sub uniq()
With Application.WorksheetFunction
divisionNames = .Unique(Range("C3:C30"))
divisionNames = .Sort(divisionNames)
End With
u = UBound(divisionNames, 1)
Range("D3:D" & 3 + u - 1).Value = divisionNames
End Sub
Unique (Dictionary)
There is no error handling i.e. it is assumed that the range is a one-column range and that there are no error or empty values. This could be easily implemented, but you wanted it short.
1D - Function
Function getUniqueColumn1D(ColumnRange As Range)
Dim Data As Variant
Data = ColumnRange.Resize(, 1).Value
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i) = key
Next key
End With
getUniqueColumn1D = Data
End Function
Sub test1D()
Dim rng As Range
Set rng = Range("C3:C30")
Dim Data As Variant
Data = getUniqueColumn1D(rng)
Debug.Print Join(Data, vbLf)
End Sub
2D - Function
Function getUniqueColumn(ColumnRange As Range)
Dim Data As Variant
Data = ColumnRange.Resize(, 1).Value
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count, 1 To 1)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i, 1) = key
Next key
End With
getUniqueColumn = Data
End Function
Sub TESTgetUniqueColumn()
Dim rng As Range
Set rng = Range("C3:C30")
Dim Data As Variant
Data = getUniqueColumn(rng)
' e.g.
Dim i As Long
For i = 1 To UBound(Data)
Debug.Print Data(i, 1)
Next i
' or:
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
2D - Sub
Sub getUniqueColumnSub()
Dim Data As Variant
Data = Range("C3:C30")
With CreateObject("Scripting.Dictionary")
Dim i As Long
For i = 1 To UBound(Data)
.Item(Data(i, 1)) = Empty
Next
ReDim Data(1 To .Count, 1 To 1)
i = 0
Dim key As Variant
For Each key In .Keys
i = i + 1
Data(i, 1) = key
Next key
End With
' e.g.
For i = 1 To UBound(Data)
Debug.Print Data(i, 1)
Next i
' or:
Range("A1").Resize(UBound(Data, 1), UBound(Data, 2)).Value = Data
End Sub
I've got two worksheets. The first (Calculation) contains 10.000 rows with a lot of RTD formulas and different calculations. The second (observer) observes the first one.
I've got a VBA script that runs every second and checks every row of worksheet 1 (Calculation). If the loop finds some marked data on worksheet 1 then it will copy some data from WS1 to WS2.
Solution 1: Loop checking 10.000 rows
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For I = 1 To 10000
If CStr(.Cells(I, 1)) = "X" Then
'DO SOME SUFF (copy the line from WS 1 to WS2)
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Solution 2: Array function with a small loop
Can I use, instead of the 10.000 row loop, an Excel Array to observe the 10.000 rows and do some stuff with the smaller array.
On worksheet 2, I would have this code: (A1:O15)
{=index(Calculation!A$1:$O$10000; .....)....))}
Again I would have a smaller loop through the 15 lines of array function:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
For K = 1 To 15
If CStr(.Cells(I, 1)) = "X" Then
'Find first empty row
LR2 = WS2.Cells(15, 1).End(xlDown).Row + 1
'Copy data from WS1 to WS2
WS1.Range(.Cells(I, 1), .Cells(I, 14)).Copy
WS2.Cells(LR2, 1).PasteSpecial xlValues
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
I would like to know what solution has the better performance.
I am not sure if an Excel array over 10.000 rows has a good performance. For sure the 15-rowLoop is faster than a 10000-row-Loop.
I don't know how to measure if a 15-row Loop in connection with an array (observing 10.000 rows) is faster.
Copy to Sheet With Criteria
Copies each row of a dataset in a worksheet containing a specified value (Criteria) in a specified column, to another worksheet.
Adjust the values in the constants section of createReport.
The data transfer will only (always) happen when the worksheet "Observer" is activated e.g. when another sheet is currently selected and the "Observer" tab is clicked on.
This code took about 5 seconds for a million (all) rows, and under a second for 100.000 rows on my machine.
The efficiency can further be improved by using the code with the Worksheet Change event in the "Calculation" worksheet and by turning off certain Application events (e.g. .ScreenUpdating, .Calculation, .EnableEvents).
Excel Test Setup (Worksheet "Calculation")
[A1:I1] ="Column "&COLUMN()
[A2] =IF(I2=1,"X","Y")
[B2:H2] =RANDBETWEEN(1,1000)
[I2] =RANDBETWEEN(1,100)
Sheet Module (Worksheet "Observer")
Option Explicit
Private Sub Worksheet_Activate()
createReport
End Sub
Standard Module e.g. Module1
Option Explicit
Sub createReport()
' Constants
' Source
Const srcName As String = "Calculation"
Const CriteriaColumn As Long = 1
Const Criteria As String = "X"
Const srcFirstCellAddress As String = "A1"
' Target
Const tgtName As String = "Observer"
Const tgtFirstCellAddress As String = "A1"
Const includeHeaders As Boolean = True
' Other
Dim wb As Workbook
Set wb = ThisWorkbook ' The workbook containing this code.
' Define Source Range ('rng').
' Define Source First Cell ('cel').
Dim cel As Range
Set cel = wb.Worksheets(srcName).Range(srcFirstCellAddress)
' Define the Current Region ('rng') 'around' First Cell.
Dim rng As Range
Set rng = cel.CurrentRegion
' Define Source Range ('rng') i.e. exclude cells to the left and above
' of Source First Cell from the Current Region.
Set rng = rng.Resize(rng.Rows.Count - cel.Row + rng.Row, _
rng.Columns.Count - cel.Column + rng.Column) _
.Offset(cel.Row - rng.Row, cel.Column - rng.Column)
' Write values from Source Range to Data Array ('Data').
Dim Data As Variant
Data = rng.Value
' Write resulting values from Data Array to Data Array
' i.e. 'shift' them to the beginning.
Dim NoC As Long ' Number of Columns
NoC = UBound(Data, 2)
Dim i As Long ' Source Data Rows Counter
Dim j As Long ' Source/Target Data Columns Counter
Dim CurrentRow As Long ' Target Data Rows Counter
Dim checkHeaders As Long
checkHeaders = -CLng(includeHeaders) ' True is '-1' in VBA.
CurrentRow = checkHeaders
For i = 1 To UBound(Data, 1)
If Data(i, CriteriaColumn) = Criteria Then
CurrentRow = CurrentRow + 1
For j = 1 To NoC
' 'Shift' from 'i' to 'CurrentRow'.
Data(CurrentRow, j) = Data(i, j)
Next j
End If
Next i
' Write values from Data Array to Target Range ('rng').
' Define Target First Cell ('cel').
Set cel = wb.Worksheets(tgtName).Range(tgtFirstCellAddress)
' Define Target First Row ('rng').
Set rng = cel.Resize(, NoC)
' Clear contents in columns.
rng.Resize(rng.Worksheet.Rows.Count - cel.Row + 1).ClearContents
Select Case CurrentRow
Case 0
GoTo CriteriaNotFound
Case checkHeaders
' Write headers from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo CriteriaNotFound
Case Else
' Write values from Data Array to Target Range.
rng.Resize(CurrentRow).Value = Data
GoTo Success
End Select
' Exit.
ProcExit:
Exit Sub
' Inform user.
CriteriaNotFound:
MsgBox "Value '" & Criteria & "' not found.", vbExclamation, "Fail"
GoTo ProcExit
Success:
MsgBox CurrentRow - checkHeaders & " row(s) of data transferred.", _
vbInformation, "Success"
GoTo ProcExit
End Sub
Rather than going back to column A 10,000 times, bring all the values into a 1D VBA array and then loop over that array:
Sub whatever()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = WorksheetFunction.Transpose(rng)
For i = 1 To 10000
If arr(i) = "X" Then
'do some stuff
End If
Next i
End Sub
If there are very few X's then it may be nearly instantaneous.
EDIT#1:
Based on Chris Neilsen's comment, here is a version that does not use Transpose():
Sub whatever2()
Dim rng As Range, arr
Set rng = Sheets("Calculation").Range("A1:A10000")
arr = rng
For i = 1 To 10000
If arr(i, 1) = "X" Then
'do some stuff
End If
Next i
End Sub
Test the next code, please. It should be very fast, using arrays and everything happening in memory. The code assumes that you need to copy all occurrences starting with the last empty cell of WS2:
Sub CopyFromWS1ToWs2Array()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, i As Long, k As Long, j As Long
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
k = k + 1 'the array row is incremented (in fact, it is the column now...)
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
End If
Next i
'the final array is Redim, preserving only the existing values:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
LR2 = WS2.cells(rows.count, 1).End(xlUp).row + 1 'last empty row of the second worksheet
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2).Select
MsgBox "Ready...", vbInformation, "Job done"
End Sub
Edited:
Please, test the next code, which should also solve your last requests (as I understood them):
Sub CopyFromWS1ToWs2ArrayBis()
Dim WS1 As Worksheet, WS2 As Worksheet, lastRow As Long, searchStr As String
Dim LR2 As Long, arr1 As Variant, arr2 As Variant, arrWS2 As Variant
Dim i As Long, k As Long, j As Long, s As Long, boolFound As Boolean
Set WS1 = ActiveSheet 'use here your necessary sheet
Set WS2 = WS1.Next 'use here your necessary sheet. I used this only for testing reason
lastRow = WS1.Range("A" & rows.count).End(xlUp).row 'last row of the first sheet
LR2 = WS2.cells(rows.count, 1).End(xlUp).row 'last empty row of the second worksheet
arr1 = WS1.Range("A1:N" & lastRow).Value 'put the range of WS1 in an array
ReDim arr2(1 To UBound(arr1, 2), 1 To UBound(arr1)) 'redim the array to be returned
'columns and rows are reversed because
'only the second dimension can be Redim Preserve(d)
arrWS2 = WS2.Range("A1:N" & LR2).Value 'put the range of WS2 in an array
searchStr = "X" 'setting the search string
For i = 1 To UBound(arr1)
If arr1(i, 1) = searchStr Then
For s = 1 To UBound(arrWS2)
If arr1(i, 1) = arrWS2(s, 1) And arr1(i, 2) = arrWS2(s, 2) And _
arr1(i, 3) = arrWS2(s, 3) Then
boolFound = True: Exit For 'if first three array columns are the same
End If
Next s
If Not boolFound Then 'if first thrree array columns not the same:
k = k + 1 'the array row is incremented
For j = 1 To UBound(arr1, 2)
arr2(j, k) = arr1(i, j) 'the row is loaded with all the necessary values
Next j
'swap the columns 4 and 5 values:
If arr1(i, 4) = "ABC" And arr1(i, 5) = "XYZ" Then arr2(4, k) = "XYZ": arr2(5, k) = "ABC"
End If
boolFound = False 'reinitialize the boolean variable
End If
Next i
If k > 0 Then
'Preserving only the existing array elements:
ReDim Preserve arr2(1 To UBound(arr1, 2), 1 To k)
'Dropping the array content at once (the fastest way of copying):
WS2.Range("A" & LR2 + 1).Resize(UBound(arr2, 2), UBound(arr2)).Value = _
WorksheetFunction.Transpose(arr2)
WS2.Activate: WS2.Range("A" & LR2 + 1).Select
MsgBox "Ready...", vbInformation, "Job done"
Else
MsgBox "No any row to be copied!", vbInformation, "Nothing changed"
End If
End Sub
I have search until I cannot find how to do this and it work properly. What I am trying to do is find a wildcard value that is more than one. I also would like to fill down column Z.
What is happening is that if I enter more than 1 wildcard it only finds one of them even though the column has many. If there is only 1 returned it inputs Tier 1 then on filldown it defaults back to Tier 2. What am I missing?
Thank you in advance for your help!
ActiveSheet.Range("$A$1:$AB$" & Rows.Count).End(xlUp).AutoFilter Field:=13, Criteria1:=Array( _
"*9365*", "*9575*", "*9375*"), _
Operator:=xlOr
With Worksheets("Raw Data").AutoFilter.Range
Range("Z" & .Offset(1, 0).SpecialCells(xlCellTypeVisible)(1).Row).Select
End With
ActiveCell.FormulaR1C1 = "Tier 1"
With ActiveSheet.UsedRange
.Resize(.Rows.Count - 1).Offset(1).Columns("Z"). _
SpecialCells(xlCellTypeVisible).FillDown
End With
I have tried the fix per #dwirony but my values return no data.
Sub AutoFilterWorkaround()
Dim sht As Worksheet
Dim filterarr As Variant, tofindarr As Variant
Dim lastrow As Long, i As Long, j As Long, k As Long
Set sht = ThisWorkbook.Worksheets("Raw Data")
lastrow = sht.Cells(sht.Rows.Count, "Z").End(xlUp).Row
'List the parts of the words you need to find here
tofindarr = Array("9365", "9375")
ReDim filterarr(0 To 0)
j = 0
For k = 0 To UBound(tofindarr)
For i = 2 To lastrow
If InStr(sht.Cells(i, 1).Value, tofindarr(k)) > 0 Then
filterarr(j) = sht.Cells(i, 1).Value
j = j + 1
ReDim Preserve filterarr(0 To j)
End If
Next i
Next k
'Filter on array
sht.Range("$A$1:$AB$" & lastrow).AutoFilter Field:=13,
Criteria1:=Array(filterarr), Operator:=xlFilterValues
End Sub
This is a picture of the result of the filtered list if I manually enter "95"
This code did the trick!
Sub AutoFilterWorkaround()
Dim sht As Worksheet
Dim filterarr As Variant, tofindarr As Variant
Dim lastrow As Long, i As Long, j As Long, k As Long
Set sht = ThisWorkbook.Worksheets("Raw Data")
lastrow = sht.Cells(sht.Rows.Count, "M").End(xlUp).Row
'List the parts of the words you need to find here
tofindarr = Array("9365", "9375")
ReDim filterarr(0 To 0)
j = 0
For k = 0 To UBound(tofindarr)
For i = 2 To lastrow
If InStr(sht.Cells(i, 13).Value, tofindarr(k)) > 0 Then
filterarr(j) = sht.Cells(i, 13).Value
j = j + 1
ReDim Preserve filterarr(0 To j)
End If
Next i
Next k
'Filter on array
sht.Range("$M$1:$M$" & lastrow).AutoFilter Field:=13,
Criteria1:=Array(filterarr), Operator:=xlFilterValues
End Sub
Anybody please help me figure my problem out?
Dim attPresent as Variant ' attpresent()
Set ws = thisworkbook.sheets("Sheet1")
lastrow = ws.cells(Rows.count, 8).end(xlup).row
attPresent = ws.Range("H4:H" & lastrow).Value 'errors if I use Dim attPresent() As Variant
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
msgbox attpresent(k,1)
Next
This line attPresent = ws.Range("H4:H" & lastrow).Value returns an error if I declare the variable as Dim attPresent() As Variant. Whereas, if declare the variable as Dim attPresent As Variant, this line For k = LBound(attPresent, 1) To UBound(attPresent, 1) errors.
Can anyone please help me clear this out?Thanks
As a good practice, try to remember to use Option Explicit, and also declare all your variables.
When you use Dim attPresent() As Variant to declare you array , and later on you insert values from a Range to your Array with attPresent = .Range("H4:H" & lastrow).Value, it will automatically Redim your array to 2-dimensinal array (1 to Row number, 1 to Column Number).
Option Explicit
Sub RngtoArray()
Dim attPresent() As Variant
Dim ws As Worksheet
Dim lastrow As Long
Dim k As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
attPresent = .Range("H4:H" & lastrow).Value
End With
For k = 1 To UBound(attPresent, 1)
MsgBox attPresent(k, 1)
Next
End Sub
Edit 1: A slightly different approach, in case there is only 1 cell in the Range:
With ws
lastrow = .Cells(.Rows.Count, 8).End(xlUp).Row
' for single column only - create a 1-Dimension array
ReDim attPresent(1 To lastrow - 4 + 1) ' when the Range starts from "H4"
For k = 1 To UBound(attPresent)
attPresent(k) = .Cells(4 + k - 1, "H")
Next k
End With
For k = 1 To UBound(attPresent)
MsgBox attPresent(k)
Next
I tried to separate the stuff that you had already defined but for clarity I thought I'd provide my full code:
Sub test()
Dim lastrow, i As Integer
Dim ws As Worksheet
Set ws = ActiveWorkbook.Worksheets("Sheet1")
Dim attPresent() As Variant
lastrow = ws.Cells(Rows.Count, "H").End(xlUp).Row
ReDim attPresent(lastrow - 4)
For i = 4 To lastrow
attPresent(i - 4) = ws.Range("H" & i).Value
Next
msg = Join(attPresent, " ")
MsgBox "The array holds: " & vbNewLine & msg
End Sub
I defined the array without a size to begin with then redefined it to the size it needs to be at a later stage once you know the lastrow (as you started on 4 i deducted 4 from lastrow).
I guessed the msgBox was to test what you had gathered so I created a dump that prints them all into one box but obviously change that if you have a lot of data. xD
To work with arrays I always loop through each individual entry, storing them one at a time. I'm not even sure whether you can dump an entire range into one in one step as I've never even looked into it. Anyway, I hope this solves your problem kupo.
Function RangeToArray(rng As Range)
Dim myArray() As Variant, ws As Worksheet
fr = rng.Row
fc = rng.Column
r = rng.Rows.Count
c = rng.Columns.Count
Set ws = rng.Worksheet
ReDim myArray(r - 1, c - 1)
For i = 0 To r - 1
For j = 0 To c - 1
myArray(i, j) = ws.Cells(fr + i, fc + j).Value2
Next j
Next i
RangeToArray = myArray
End Function
Sub f()
Dim rng As Range, attPresent() As Variant ' attpresent()
Set ws = ThisWorkbook.ActiveSheet 'Sheets("Sheet1")
lastrow = ws.Cells(Rows.Count, 8).End(xlUp).Row
Set rng = ws.Range("H4:H" & lastrow)
attPresent = RangeToArray(rng)
For k = LBound(attPresent, 1) To UBound(attPresent, 1) ' Dim attPresent As Variant'errors if I use
MsgBox attPresent(k, 0)
Next
End Sub
I created a more generic function that you can call in this specific case as well.
I am trying to pull strings from column A and move them to column B only if they don't already exist in column B. To do this, I wanted to make a list and scan all of column A with it, however, I'm not sure how to do that in VBA. In python I recall using something along the lines of
[If (x) not in (List)]
but that same approach isnt working for me in Excel.
Currently, I have the following
Sub GatherAll()
GL = List()
rwcnt = WorksheetFunction.CountA(Range("A:A"))
lastc = Cells(1, Columns.Count).End(xlToLeft).Column
Dim i As Long
For i = 2 To rwcnt
Cells(i, 1).Value = n
and I want to say something like
if n not in GL, GL.append(n)
continue
End Sub
If anyone could help me out, I would really appreciate it.
Try adapting the following code to your exact needs and see if it helps. If you need help, let us know.
Sub MoveUniqueEntries()
Dim oDict As Object
Dim rToMove As Range
Dim rDest As Range
Dim rLoop As Range
Set oDict = CreateObject("Scripting.Dictionary")
Set rToMove = Intersect(Sheet1.Range("A1").CurrentRegion, Sheet1.Columns(1))
Set rDest = Sheet1.Range("B1")
For Each rLoop In rToMove
If oDict.exists(rLoop.Value) Then
'Do nothing
Else
oDict.Add rLoop.Value, 0
rDest.Value = rLoop.Value
Set rDest = rDest.Offset(1)
End If
Next rLoop
End Sub
In your VBA IDE you will have to add a reference. On the tools pulldown menu select references. Then select "Microsoft ActiveX Data Objects 2.8 Library".
Dim rs As New ADODB.Recordset
Dim ws As Excel.Worksheet
Dim lRow As Long
Set ws = Application.ActiveSheet
'Add fields to your recordset for storing data. You can store sums here.
With rs
.Fields.Append "Row", adInteger
.Fields.Append "Value", adInteger
.Open
End With
lRow = 1
'Loop through and record what is in the first column
Do While lRow <= ws.UsedRange.Rows.count
rs.AddNew
rs.Fields("Row").Value = lRow
rs.Fields("Value").Value = ws.Range("A" & lRow).Value
rs.Update
lRow = lRow + 1
ws.Range("A" & lRow).Activate
Loop
'Now go through and list out the unique values in columnB.
lRow = 1
rs.Sort = "value"
Do While lRow <= ws.UsedRange.Rows.count
if rs.Fields("value").Value <> strLast then
ws.Range("B" & lRow).Value = rs.Fields("value").Value
lRow = lRow + 1
End if
strLast = rs.Fields("value").Value
Loop
Cross-platform version (but will be slow for large numbers of values):
Sub UniquesTester()
Dim v, u(), i As Long, n As Long
n = 0
v = Range(Range("A1"), Cells(Rows.Count, 1).End(xlUp)).Value
ReDim u(1 To UBound(v, 1))
For i = 1 To UBound(v, 1)
If IsError(Application.Match(v(i, 1), u, 0)) Then
n = n + 1
u(n) = v(i, 1)
End If
Next i
ReDim Preserve u(1 To n)
Range("c1").Resize(n, 1).Value = Application.Transpose(u)
End Sub