I found this code in this forumn. I want to copy this unique values into an array
Dim sheetName As String
sheetName = Application.InputBox("Enter Sheet Name")
Sheets(sheetName).Range("E:E").AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=Sheets(sheetName).Range("O:O"), unique:=True
If you want to cut out the range middleman, you can get the values directly into a 1-dimensional VBA array by using a dictionary to make sure that only unique values are grabbed:
Function UniqueVals(Col As Variant, Optional SheetName As String = "") As Variant
'Return a 1-based array of the unique values in column Col
Dim D As Variant, A As Variant, v As Variant
Dim i As Long, n As Long, k As Long
Dim ws As Worksheet
If Len(SheetName) = 0 Then
Set ws = ActiveSheet
Else
Set ws = Sheets(SheetName)
End If
n = ws.Cells(Rows.Count, Col).End(xlUp).Row
ReDim A(1 To n)
Set D = CreateObject("Scripting.Dictionary")
For i = 1 To n
v = ws.Cells(i, Col).Value
If Not D.Exists(v) Then
D.Add v, 0
k = k + 1
A(k) = k
End If
Next i
ReDim Preserve A(1 To k)
UniqueVals = A
End Function
For example, UniqueVals("E",sheetName) will return an array consisting of the unique values in column E of sheetName.
Here's another method using VBA's Collection object instead of a dictionary.
Sub Dural()
Dim sheetName As String
Dim V As Variant, COL As Collection
Dim I As Long
Dim vUniques() As Variant
sheetName = Application.InputBox("Enter Sheet Name")
'Copy all data into variant array
' This will execute significantly faster than reading directly
' from the Worksheet range
With Worksheets(sheetName)
V = .Range(.Cells(1, "E"), .Cells(.Rows.Count, "E").End(xlUp))
End With
'Collect unique values
'Use the key property of the collection object to
' ensure no duplicates are collected
' (Trying to assign the same key to two items fails with an error
' which we ignore)
Set COL = New Collection
On Error Resume Next
For I = 1 To UBound(V, 1)
COL.Add Item:=V(I, 1), Key:=CStr(V(I, 1))
Next I
On Error GoTo 0
'write collection to variant array
ReDim vUniques(1 To COL.Count)
For I = 1 To COL.Count
vUniques(I) = COL(I)
Next I
Stop
End Sub
Another version, also using a dictionary. It works for me, but I must admit that still don't know how it works (I'm a beginner). I found this code somewhere in Stackoverflow, but can't spot the place.
Dim dU1 As Object, cU1 As Variant, iU1 As Long, lrU As Long
Dim i As Integer
Private Sub Go_Click()
Set dU1 = CreateObject("Scripting.Dictionary")
lrU = Cells(Rows.Count, 1).End(xlUp).Row
cU1 = Range("E1:E" & lrU)
For iU1 = 1 To UBound(cU1, 1)
dU1(cU1(iU1, 1)) = 1
Next iU1
For i = 0 To dU1.Count - 1
MsgBox "dU1 has " & dU1.Count & " elements and key#" & i & " is " & dU1.Keys()(i)
Next
End Sub
Related
There are around 1000 different "customer_ids" in total. These can also occur several times in the file on several worksheets.
The "customer_id" data records should be automatically overwritten with a new name. The designation represents a format consisting of a fixed sequence of letters + a consecutive, ascending number -> ABC1, ABC2, ..., ABCn. See figure above left.
The name of the row-header and its position can be different in the worksheets. This means that the "customer_id" can also be found as "cust_id" in columns other than "A". See figures.
The recurring customer_id's should have the same name on all worksheets, see figures.
Please, test the next (working) solution:
Edited:
Please, try the next version (using arrays) which should be much faster:
Option Explicit
Sub ChangeIDPart2()
Const idBaseName As String = "ABC"
Const ColNamesList As String = "customer_id,cust_id" ' add more
Const HeaderRow As Long = 1
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
Dim fRow As Long: fRow = HeaderRow + 1
Dim ColNames() As String: ColNames = Split(ColNamesList, ",")
Dim cUpper As Long: cUpper = UBound(ColNames)
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare ' ignore case of 'idBaseName'
Dim ws As Worksheet ' Current Worksheet
Dim rrg As Range ' Entire Row of Headers
Dim arr As Variant ' ID Column Range array (changed...)
Dim cCell As Range ' Current Cell in ID Column Range
Dim cIndex As Variant ' Current ID Column (could be an error value)
Dim Key As Variant ' Current ID (string)
Dim lRow As Long ' ID Column Last Non-Empty (Not Hidden) Row
Dim n As Long ' New ID Incrementer
Dim i As Long ' Column Names (Titles, Headers) Counter
Dim foundHeader As Boolean ' Found Header Boolean
For Each ws In wb.Worksheets
fRow = HeaderRow + 1
Set rrg = ws.Rows(HeaderRow)
For i = 0 To cUpper
cIndex = Application.Match(ColNames(i), rrg, 0)
If IsNumeric(cIndex) Then
foundHeader = True
Exit For
End If
Next i
If Not foundHeader Then
Dim k As Long
For k = 1 To 5
Set rrg = ws.Rows(HeaderRow + k)
For i = 0 To cUpper
cIndex = Application.Match(ColNames(i), rrg, 0)
If IsNumeric(cIndex) Then
fRow = rrg.row + 1
foundHeader = True
Exit For
End If
Next i
If foundHeader Then Exit For
Next k
End If
If Not foundHeader Then MsgBox "In sheet " & ws.Name & _
" an appropriate header could not be found in first 6 rows..."
If foundHeader Then
foundHeader = False ' reset
lRow = ws.Cells(ws.Rows.Count, cIndex).End(xlUp).Row
If lRow > 1 Then ' check if any id's
arr = ws.Range(ws.Cells(fRow, cIndex), _
ws.Cells(lRow, cIndex)).Value 'put the range in array (to iterate faster)
For i = 1 To UBound(arr)
Key = CStr(arr(i, 1))
If Key <> "" Then
If Not dict.Exists(Key) Then
n = n + 1
dict.Add Key, idBaseName & n
End If
arr(i, 1) = dict(Key)
End If
Next i
ws.Range(ws.Cells(fRow, cIndex), _
ws.Cells(lRow, cIndex)).Value = arr 'drop back in the range the processed array
End If
End If
Next ws
MsgBox "Done.", vbInformation, "Change ID Part 2"
End Sub
Please, test it and send some feedback. I am curious how much it takes. Theoretically, it should be obviously faster.
I have the following VBA code in Excel 2010 that reads the numbers in column A into a comma separated string.
The numbers are sorted in column A
However, I was wondering if there was a way to either remove the duplicate numbers while reading them to to the comma separated variable, or a way to remove all the duplicates from the variable after it has been built.
Here is my code that builds the comma separated list
Dim LR As Long
Dim RangeOutput
Dim entry As Variant
Dim FinalResult As String
LR = Range("A" & Rows.Count).End(xlUp).Row
On Error Resume Next 'if only 1 row
For Each entry In ThisWorkbook.Sheets("Sheet1").Range("A2:A" & LR)
If Not IsEmpty(entry.Value) Then
RangeOutput = RangeOutput & entry.Value & ","
End If
Next
FinalResult = Left(RangeOutput, Len(RangeOutput) - 1)
This is how you can do it with a dictionary.
Dim arrData As Variant
Dim dic As Object
Dim idx As Long
arrData = Range("A2").CurrentRegion.Columns(1).Value
Set dic = CreateObject("Scripting.Dictionary")
For idx = 2 To UBound(arrData, 1)
If arrData(idx, 1) <> "" Then
dic(arrData(idx, 1)) = ""
End If
Next idx
FinalResult = Join(dic.keys, ",")
You can use a Collection to achieve same result:
Option Explicit
Sub Test()
Dim ws As Worksheet
'
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Sheet1")
On Error GoTo 0
If ws Is Nothing Then
MsgBox "Missing required worksheet", vbExclamation, "Cancelled"
Exit Sub
End If
'
Dim lastRowIndex As Long
'
lastRowIndex = ws.Range("A" & Rows.Count).End(xlUp).Row 'Notice the range is fully referenced with the sheet
If lastRowIndex = 1 Then
MsgBox "No data found in column A", vbInformation, "Cancelled"
Exit Sub
End If
'
Dim arrValues As Variant
'
arrValues = ws.Range("A2:A" & lastRowIndex).Value2
If Not IsArray(arrValues) Then arrValues = Array(arrValues) 'Just in case lastRow is 2
'
Dim v As Variant
Dim uniqueValues As New Collection
'
On Error Resume Next 'For duplicated values - collections do not allow duplicated keys
For Each v In arrValues
uniqueValues.Add v, CStr(v)
Next v
On Error GoTo 0
'
Dim arrResult() As Variant
Dim i As Long
Dim result As String
'
ReDim arrResult(0 To uniqueValues.Count - 1)
i = 0
For Each v In uniqueValues
arrResult(i) = CStr(v) 'In case there are errors like #N/A
i = i + 1
Next v
'
result = Join(arrResult, ",")
Debug.Print result
End Sub
I have autofiltered a worksheet and am trying to establish the unique values within the filtered data. I feel like I have the correct approach, but the my results only show 2 of the possible 8 unique values.
Private Sub GetAllCampusDomains(DomainCol As Collection)
Dim data(), dict As Object, r As Long, i%, lastrow As Long
Set dict = CreateObject("Scripting.Dictionary")
'Clear the previous filter
shtData.ShowAllData
'Filter the data
shtData.Range("A:Y").AutoFilter Field:=6, Criteria1:=shtSetup.Range("CampusName") 'SchoolName
shtData.Range("A:Y").AutoFilter Field:=9, Criteria1:="DomainPerformance" 'ColI
'Inspect the visible cells in ColP
lastrow = shtData.Cells(shtData.Rows.Count, "P").End(xlUp).row
data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
'Find the unique values
For r = 1 To UBound(data)
dict(data(r, 1)) = Empty
Next
data = WorksheetFunction.Transpose(dict.keys())
'Walk through the unique values
For i = 1 To UBound(data)
Debug.Print data(i, 1)
'DomainCol.Add data(i, 1)
Next i
End Sub
The error seems to have to do with this line:
data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
This call only seems to create a 90x1 sized array, when it should be much bigger.
I greatly appreciate your help!
Josh
Non-Contiguous Column Range to Jagged Array
Instead of...
data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
'Find the unique values
For r = 1 To UBound(data)
dict(data(r, 1)) = Empty
Next
...use the following...
Private Sub GetAllCampusDomains(DomainCol As Collection)
'...
Dim rng As Range
Set rng = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
getNonContiguousColumn Data, rng
'Find the unique values
Dim j As Long
For j = 0 To UBound(Data)
For r = 1 To UBound(Data(j))
dict(Data(j)(r, 1)) = Empty
Next r
Next j
'...
End Sub
...backed up by the following:
Sub getNonContiguousColumn(ByRef Data As Variant, _
NonContiguousColumnRange As Range, _
Optional FirstIndex As Long = 0)
Dim j As Long
j = FirstIndex - 1
ReDim Data(FirstIndex To NonContiguousColumnRange.Areas.Count + j)
Dim ar As Range
Dim OneCell As Variant
ReDim OneCell(1 To 1, 1 To 1)
For Each ar In NonContiguousColumnRange.Areas
j = j + 1
If ar.Cells.Count > 1 Then
Data(j) = ar.Value
Else
OneCell(1, 1) = ar.Value
Data(j) = OneCell
End If
Next ar
End Sub
Test the previous Sub with something like the following:
Sub testGetNCC()
Const rngAddr As String = "A2:A20"
Dim Data As Variant
Dim rng As Range
Set rng = Range(rngAddr).SpecialCells(xlCellTypeVisible)
getNonContiguousColumn Data, rng
Dim j As Long, i As Long
For j = 0 To UBound(Data)
For i = 1 To UBound(Data(j))
Debug.Print Data(j)(i, 1)
Next i
Next j
End Sub
Please, replace this piece of code:
data = shtData.Range("P2:P" & lastrow).SpecialCells(xlCellTypeVisible)
'Find the unique values
For r = 1 To UBound(data)
dict(data(r, 1)) = Empty
Next
with the next one:
Dim rng As Range, C As Range
Set rng = shtData.Range("P2:P" & lastRow).SpecialCells(xlCellTypeVisible)
'Find the unique values
For Each C In rng.cells
dict(C.Value) = Empty
Next
Your initial code iterates between the first area range cells.
The second one will iterate between all visible range cells...
I need to compare two ranges and see if value in one range appears in the other. This is the code I use:
Dim rng1 As Range
Dim rng2 As Range
Dim cell as Range
Dim found as Range
set rng1 = ....
set rng2 = ....
for each cell in rng1
set found = rng2.Find(what:=cell,.....
Next cell
This code is OK if the range is in thousands of rows, single column. When it comes to tens of thousands, it's very slow.
Anyway to speed it up?
This might be the fastest way for large amounts of data:
Option Explicit
Sub Test()
Dim rng1 As Range
Set rng1 = YourShorterRange
Dim rng2 As Range
Set rng2 = YourLargerRange
Dim C As Range
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
'input the larger data inside a dictionary
For Each C In rng2
If Not Matches.Exists(C.Value) Then Matches.Add C.Value, 1
Next C
Dim i As Long
Dim arr As Variant
'input the shorter data inside an array
arr = rng1.Value
For i = 1 To UBound(arr)
If Matches.Exists(arr(i, 1)) Then
'your code if the value is found
End If
Next i
End Sub
Edit for Dorian:
Option Explicit
Sub Test()
Dim rng1 As Range
Set rng1 = YourShorterRange
Dim rng2 As Range
Set rng2 = YourLargerRange
Dim i As Long, j As Long
Dim arr As Variant
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
arr = rng1.Value
'input the larger data inside a dictionary
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not Matches.Exists(arr(i, j)) Then Matches.Add arr(i, j), 1
Next j
Next i
'input the shorter data inside an array
arr = rng2.Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Matches.Exists(arr(i, j)) Then
'your code if the value is found
End If
Next j
Next i
End Sub
Maybe something along these lines:
Sub Test()
Dim arr1 As Variant, arr2 As Variant
Dim arrList As Object: Set arrList = CreateObject("System.Collections.ArrayList")
Dim x As Long
arr1 = rng1 'Specify your range
arr2 = rng2 'Specify your range
For x = LBound(arr2) To UBound(arr2)
arrList.Add arr2(x, 1)
Next x
For x = LBound(arr1) To UBound(arr1)
If arrList.contains(arr1(x, 1)) = True Then
Debug.Print arr1(x, 1) & " contained within range 2"
End If
Next x
End Sub
I would suggest you :
Application.match
You can also look here you will find an interesting studies on 3 different ways of Search. Those 3 Different way will be studied By Time and By number of occurences.
According Fastexcel the conclusion of this study is :
Don’t use Range.Find unless you want to search a large number of
columns for the same thing (you would have to do a Match for each
column).
The Variant array approach is surprisingly effective,
particularly when you expect a large number of hits.
Match wins easily
for a small number of hits.
So If you except a large number of hit you might have to give a try variant array method. The 3 ways are listed in Fastexcel tuto
Edit
After reading some comment I did a new test :
Variant code
Sub Test1()
Dim vArr As Variant
Dim j As Long
Dim n As Long
Dim dTime As Double
dTime = MicroTimer
vArr = Range("A1:B100000").Value2
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
arr = Range("G1:G15").Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not Matches.Exists(arr(i, j)) Then Matches.Add arr(i, j), 1
Next j
Next i
For j = LBound(vArr) To UBound(vArr)
If Matches.Exists(vArr(j, 1)) Or Matches.Exists(vArr(j, 2)) Then n = n + 1
Next j
Debug.Print "Using Variant : " & n & " Timer :" & (MicroTimer - dTime) * 1000
End Sub
Dictionary
Sub Test()
Dim rng1 As Range
Set rng1 = Range("A1:B100000")
Dim rng2 As Range
Set rng2 = Range("G1:G15")
Dim i As Long, j As Long
Dim arr As Variant
Dim dTime As Double
dTime = MicroTimer
Dim Matches As Object: Set Matches = CreateObject("Scripting.Dictionary")
arr = rng2.Value
'input the larger data inside a dictionary
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Not Matches.Exists(arr(i, j)) Then Matches.Add arr(i, j), 1
Next j
Next i
'input the shorter data inside an array
arr = rng1.Value
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
If Matches.Exists(arr(i, j)) Then
'your code if the value is found
cpt = cpt + 1
End If
Next j
Next i
Debug.Print "Using Damian Method : " & cpt & " Timer : " & (MicroTimer - dTime) * 1000
End Sub
I have to capture sheet row into a 2d array. I am using the following code
Code :
Sub multiarr()
Dim str As String 'String Which i am looking for
Dim result() As String 'Stores Splitted Substring
Dim r As Integer ' Row Counter of 2d array
Dim c As Integer ' Column Counter of 2d Array
Dim valarr() As String ' Initial Declaration of Array
'Row and Column Initialization
r = 0
c = 0
'Calculate Last Row and Last Column of Sheet
mylr = Cells(Rows.Count, 1).End(xlUp).Row
lcol = Cells(1, Columns.Count).End(xlToLeft).Column
'Initialize the Array according to Sheet Dimentions
ReDim valarr(mylr - 2, lcol - 1) 'Declare Array to be of size of Sheet
str = "M1" ' -> This i am interested in.Only these records will be populated
For y = 0 To UBound(valarr) 'iterate through rows of array
For x = 2 To mylr 'iterate through rows of sheet
result = Split(Cells(x, 1), "#") ' Split the Record
If result(0) = str Then 'Check for the Condition
'Array Filling Logic
For c = 1 To lcol
' C-1 because column index starts from 0
valarr(y, c - 1) = Cells(x, c)
Next c
End If
Next x
Next y
End Sub
But this code is incorrectly filling. What is the problem?
Please refer sample image of worksheet
Thanks in advance
Please see the bellow, hope it helps
Sub multiarr()
Dim str As String 'String Which i am looking for
Dim result() As String 'Stores Splitted Substring
Dim r As Integer ' Row Counter of 2d array
Dim c As Integer ' Column Counter of 2d Array
Dim valarr() As String ' Initial Declaration of Array
Dim mylr As Long, lcol As Long 'lastrow / lastcol
'I recommend declaring the workbook/worksheet and declaring the ranges accordingly
'Without doing so, any range refence bellow is explicit to the ActiveSheet
Dim arrValues As Variant
Dim cnt As Long, cnt2 As Long
'Row and Column Initialization
r = 1
c = 1
'Calculate Last Row and Last Column of Sheet
mylr = Cells(Rows.Count, 1).End(xlUp).row
lcol = Cells(1, Columns.Count).End(xlToLeft).column
arrValues = Range(Cells(r, c), Cells(mylr, lcol))
str = "M1" ' -> This i am interested in.Only these records will be populated
For y = LBound(arrValues) To UBound(arrValues) 'Iterate through values
If Left(arrValues(y, 1), 2) = str Then 'Check if the correct value exists
cnt = cnt + 1 'Count the number of occurences
End If
Next y
'Initialize the Array according to Results Dimentions
ReDim valarr(1 To cnt, 1 To lcol) 'Declare Array to be of size of Sheet
cnt2 = 1 'Start at one to match the array of the values, but... feel free to change
For y = LBound(arrValues) To UBound(arrValues) 'Iterate through array rows
If Left(arrValues(y, 1), 2) = str Then 'Check if the correct value exists
For z = LBound(arrValues, 2) To UBound(arrValues, 2) 'Iterate through array columns
valarr(cnt2, z) = arrValues(y, z) 'Add to the arr only correct values
Next z
cnt2 = cnt2 + 1 'If value find, we increase the counter
End If
Next y
End Sub
this answer only addresses the issue of getting a range into a 2-D array, not the processing of the elements.
This code is a pretty efficient method:
Sub multiarr()
Dim str As String 'String Which i am looking for
Dim result() As String 'Stores Splitted Substring
Dim r As Integer ' Row Counter of 2d array
Dim c As Integer ' Column Counter of 2d Array
Dim valarr()
valarr = Range("A1").CurrentRegion
MsgBox LBound(valarr, 1) & "-" & UBound(valarr, 1) & vbCrLf & LBound(valarr, 2) & "-" & UBound(valarr, 2)
End Sub
If you can't adapt the approach to your needs, ignore this answer.
Use auto filter (see comments in code):
Sub multiarr()
Dim rng As Range, rngData As Range, rngFilter As Range
'// Full range
Set rng = Range("A1").CurrentRegion
'// Range without a header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=1, Criteria1:="M1*"
'// Error handling in case if no rows will be filtered
On Error Resume Next
Set rngFilter = rngData.SpecialCells(xlCellTypeVisible)
If Err = 0 Then
'// Do something with your range.
'// Do not forget to use Areas,
'// since rngFilter can be non-contiguous:
'// Dim cell As Range, rngRow As Range, rngArea As Range
'// For Each rngArea in rngFilter.Areas
'// For Each cell in rngArea
'// 'Or For Each rngRow in rngArea.Rows
'// // Do something...
'// Next
'// Next
End If
On Error GoTo 0
End Sub