Excel VBA Create a list and add only unique terms - arrays

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

Related

Array of unique values in a Column range

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

List all unique values based on criterias

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.

Adding values to a dynamic array and then printing to specified cell

I'm searching a range in my sheet for certain values when either of these values is found I want to add the value from column A of that row to an array, only adding values that are not already present in the array. Once the range has been searched, I want to print the arrays to specified cells in the worksheet in 2 different columns.
Here's my code so far:
Dim Ws As Worksheet
Set Ws = Sheets("Sheet1")
Dim Leave() As Variant, Join() As Variant
Dim LastCol As Integer, LastRow As Integer, i As Integer, Z As Integer
Dim J As Long, L As Long
With Sheets("Sheet1")
'Find Last Col
LastCol = Sheets("Sheet1").Cells(3, Columns.Count).End(xlToLeft).Column
'Find last Row
LastRow = Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
LastRow = LastRow - 1
'ReDim Leave(1 To (LastRow - 1), LastCol)
'ReDim Join(1 To (LastRow - 1), LastCol)
For i = 5 To LastCol
For Z = 4 To LastRow
If Sheets("Sheet1").Cells(Z, i).Value = "0" Then
Leave(L) = Ws.Cells(Z, 1).Value
ElseIf Sheets("Sheet1").Cells(Z, i).Value = "-2" Then
Join(J) = Ws.Cells(Z, 1).Value
End If
Next Z
Next i
'Print array
End With
Thanks for any pointers/help in advance!
I believe this procedure accomplishes what you are looking for. You will need to modify the range in which you are searching and the destination sheet information, but the meat of the procedure is here:
Sub abc_Dictionary()
Dim oWS As Worksheet
Dim RangeToSearch As Range
Dim myCell As Range
Dim UniqueDict As Object
Set oWS = Worksheets("Sheet1")
Set RangeToSearch = oWS.Range("B1:B26") 'You can set this dynamically however you wish
Set UniqueDict = CreateObject("Scripting.Dictionary")
'Now we search the range for the given values.
For Each myCell In RangeToSearch
If (myCell.Text = "0" Or myCell.Text = "-2") And Not UniqueDict.exists(oWS.Range("A" & myCell.Row).Text) Then
UniqueDict.Add oWS.Range("A" & myCell.Row).Text, oWS.Range("A" & myCell.Row).Text
End If
Next
'Now we have a dictionary object with the unique values of column a
'So we just iterate and dump into Sheet2
Dim d As Variant
Dim Val As Variant
Dim DestRow As Integer
DestRow = 1 'This is the first row of data we will use on Sheet 2
d = UniqueDict.Items
For Each Val In d
Worksheets("Sheet2").Range("A" & DestRow).Value = Val
DestRow = DestRow + 1
Next
Set UniqueDict = Nothing
Set RangeToSearch = Nothing
Set oWS = Nothing
End Sub

Error in converting Range to arrays

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.

How to name new worksheets based on values in array and copy associated values from original data set?

I have data in columns P,Q,R. I would like to filter through R, and make a new Worksheet for each unique item in Column R. This new worksheet will also bring along the associated values in P and Q.
Thus far I have learned how to filter the data in R and put the unique values into an array. For each value in the array I made a new sheet named Array1(i) because I am unable to convert the value into a string for some reason. How can I do this in an optimized fashion such that I create a new sheet for each unique value in R and bring along the values in the same rows in P and Q as well? Here is my code:
Also, how do I declare the array dynamically rather than hard coding 50? How can I use a dynamic range for column R?
Note the values in the array will be something like 6X985
Sub testarray()
Dim TestRg As Excel.Range
Dim Array1(50) As Variant
Dim SheetName As String
Dim i, j, k As Integer
i = 1
Set TestRg = Range("R1:R36879")
TestRg.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
For Each c In TestRg.SpecialCells(xlCellTypeVisible)
Array1(i) = c.Value
'SheetName = CStr(c.Value)
Worksheets.Add.Name = i
i = i + 1
Next c
j = i - 1
i = 1
Worksheets("Sheet1").ShowAllData
For Each c In Range("S3:S" & j)
c.Value = Array1(i)
i = i + 1
Next c
k = 1
For Each d In Range("T3:T" & j)
d.Value = k
k = k + 1
Next d
End Sub
The code itself is kind of advanced, I added comments to assist with understanding. I hope it helps:
Sub tgr()
Dim wsData As Worksheet
Dim wsNew As Worksheet
Dim rngData As Range
Dim xlCalc As XlCalculation
Dim arrUnq() As Variant
Dim strSheetName As String
Dim UnqIndex As Long
Dim i As Long
Set wsData = Sheets("Sheet1")
Set rngData = wsData.Range("R1", wsData.Cells(Rows.Count, "R").End(xlUp))
'Disable application items to let code run faster
With Application
xlCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
End With
'Re-enable all the application items just in case there's an error
On Error GoTo CleanExit
'Get the list of unique values from rngData, sorted alphabetically
'Put that list into the arrUnq array
With Sheets.Add
rngData.AdvancedFilter xlFilterCopy, , .Range("A1"), True
.UsedRange.Sort .UsedRange, xlAscending, Header:=xlYes
arrUnq = Application.Transpose(.Range("A2", .Cells(Rows.Count, "A").End(xlUp)).Value)
.Delete
End With
For UnqIndex = LBound(arrUnq) To UBound(arrUnq)
'Verify a valid worksheet name
strSheetName = arrUnq(UnqIndex)
For i = 1 To 7
strSheetName = Replace(strSheetName, Mid(":\/?*[]", i, 1), " ")
Next i
strSheetName = Trim(Left(WorksheetFunction.Trim(strSheetName), 31))
'Check if worksheet name already exists
If Not Evaluate("ISREF('" & strSheetName & "'!A1)") Then
'Sheet doesn't already exist, create sheet
Sheets.Add(After:=Sheets(Sheets.Count)).Name = strSheetName
End If
Set wsNew = Sheets(strSheetName)
wsNew.UsedRange.Clear
'Filter for the unique data
With rngData
.AutoFilter 1, arrUnq(UnqIndex)
'Copy the data from columns P:R to the new sheet
Intersect(wsData.Range("P:R"), .EntireRow).SpecialCells(xlCellTypeVisible).Copy wsNew.Range("A1")
End With
Next UnqIndex
rngData.AutoFilter 'Remove any remaining filters
CleanExit:
With Application
.Calculation = xlCalc
.ScreenUpdating = True
.EnableEvents = True
.DisplayAlerts = True
End With
If Err.Number <> 0 Then
MsgBox Err.Description, , "Error: " & Err.Number
Err.Clear
End If
End Sub

Resources