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
Related
I've written the below function intended to take an input array, delete the duplicates and return an array of unique values. I've looked at other functions open source that are similar but could not get them to work either. Watching both input array and the function arrays, Arr and ArrCopy, they have the correct number and value for each index. Any ideas why I'm getting an out of range error?
Public Function getUnique(Arr As Variant) As Variant
Dim ArrCopy As Variant
Dim i As Variant
Dim j As Variant
Dim counter As Integer
'copies input array, loops through copy and clears dupates
ArrCopy = Arr
For i = LBound(Arr) To UBound(Arr)
For j = LBound(ArrCopy) To UBound(ArrCopy)
If Arr(i) = ArrCopy(j) And i <> j Then
ArrCopy(j).Clear
End If
Next j
Next i
'clears array, loops through copy and puts nonzero values back in Arr
Arr.Clear
counter = 0
For i = LBound(ArrCopy) To UBound(ArrCopy)
If ArrCopy(i) <> "" Then
ReDim Preserve Arr(0 To counter)
Arr(counter) = ArrCopy(i)
counter = counter + 1
End If
Next i
'returns unique values
getUnique = Arr
End Function
Update: This is how the array gets loaded. From FaneDuru's comment, I see in the watch table that the input array is actually 2D, so that's why I'm getting an out of range error....
'removes blanks from AO
wks.AutoFilterMode = False
wks.Range("A1:BO" & lastrow).AutoFilter Field:=41, Criteria1:="<>", Operator:=xlFilterValues
Set rng = wks.Range("AO2:AO" & lastrow).SpecialCells(xlCellTypeVisible)
'loads SNs into array
Erase serialNum
serialNum = rng.Value
Update 2:
This has me a lot closer. Using the 2d approach This will set all of the repeats to 0. Then I call a delete element sub I found (Deleting Elements in an Array if Element is a Certain value VBA). I am modifying the original to work with 2D array. I am getting a subscript out of range error on my Redim Preserve line within the DeleteElementAt() sub.
Public Function GetUnique(Arr As Variant) As Variant
Dim i As Variant
Dim j As Variant
Dim counter As Integer
For i = LBound(Arr) To UBound(Arr)
For j = LBound(Arr) To UBound(Arr)
If i <> j And Arr(i, 1) = Arr(j, 1) Then
Arr(j, 1) = "0"
End If
Next j
Next i
counter = 0
For i = LBound(Arr) To UBound(Arr)
If Arr(i, 1) = "0" Then
Call DeleteElementAt(i, Arr)
ReDim Preserve Arr(0 To UBound(Arr))
End If
Next i
GetUnique = Arr
End Function
Public Sub DeleteElementAt(ByVal index As Integer, ByRef Arr As Variant)
Dim i As Integer
' Move all element back one position
For i = index + 1 To UBound(Arr)
Arr(index, 1) = Arr(i, 1)
Next i
' Shrink the array by one, removing the last one
'ERROR HERE
ReDim Preserve Arr(LBound(Arr) To UBound(Arr) - 1, 1)
End Sub
Return the Unique Values From a Range in an Array
Option Explicit
Sub Test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets("Sheet1")
Dim rg As Range: Set rg = ws.Range("A2:J21")
Dim Data As Variant: Data = GetRange(rg)
Dim Arr As Variant: Arr = ArrUniqueData(Data)
' Continue using 'Arr', e.g.:
If Not IsEmpty(Arr) Then
Debug.Print Join(Arr, vbLf)
Else
Debug.Print "Nope."
End If
' Dim n As Long
' For n = 0 To UBound(Arr)
' Debug.Print Arr(n)
' Next n
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the values of a range ('rg') in a 2D one-based array.
' Remarks: If ˙rg` refers to a multi-range, only its first area
' is considered.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetRange( _
ByVal rg As Range) _
As Variant
Const ProcName As String = "GetRange"
On Error GoTo ClearError
If rg.Rows.Count + rg.Columns.Count = 2 Then ' one cell
Dim Data As Variant: ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
GetRange = Data
Else ' multiple cells
GetRange = rg.Value
End If
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Writes the unique values from a 2D array
' to a 1D zero-based array, excluding error values and blanks.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrUniqueData( _
Data As Variant, _
Optional ByVal CompareMethod As VbCompareMethod = vbTextCompare) _
As Variant
Const ProcName As String = "ArrUniqueDatae"
On Error GoTo ClearError
Dim cLower As Long: cLower = LBound(Data, 2)
Dim cUpper As Long: cUpper = UBound(Data, 2)
Dim Key As Variant
Dim r As Long
Dim C As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = CompareMethod
For r = LBound(Data, 1) To UBound(Data, 1)
For C = cLower To cUpper
Key = Data(r, C)
If Not IsError(Key) Then ' exclude error values
If Len(Key) > 0 Then ' exclude blanks
.Item(Key) = Empty
End If
End If
Next C
Next r
If .Count = 0 Then Exit Function
ArrUniqueData = .Keys
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
EDIT
This will continue your sub using the (SpecialCells) filtered one-column range. You still need the previous procedures (except the Test procedure) and there is a new function below.
' This is your procedure!
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: ...
' Calls: GetFilteredColumn
' GetRange
' ArrUniqueData
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub YourProcedure()
' ... whatever
Set Rng = wks.Range("AO2:AO" & lastrow).SpecialCells(xlCellTypeVisible)
'Erase serialNum ' you don't need to erase
serialNum = GetFilteredColumn(Rng)
Dim Arr As Variant: Arr = ArrUniqueData(serialNum)
' Continue using 'Arr', e.g.:
If Not IsEmpty(Arr) Then
Debug.Print Join(Arr, vbLf)
Else
Debug.Print "Nope."
End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose: Returns the filtered values of a column range
' in a 2D one-based array.
' Calls: GetRange.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFilteredColumn( _
ByVal FilteredColumnRange As Range) _
As Variant
Const ProcName As String = "GetFilteredColumn"
On Error GoTo ClearError
With FilteredColumnRange
Dim aCount As Long: aCount = .Areas.Count
Dim aData As Variant: ReDim aData(1 To aCount)
Dim arg As Range
Dim a As Long
For Each arg In .Areas
a = a + 1
aData(a) = GetRange(arg)
Next arg
Dim dData As Variant: ReDim dData(1 To .Cells.Count, 1 To 1)
Dim sr As Long
Dim dr As Long
For a = 1 To aCount
For sr = 1 To UBound(aData(a), 1)
dr = dr + 1
dData(dr, 1) = aData(a)(sr, 1)
Next sr
Next a
GetFilteredColumn = dData
End With
ProcExit:
Exit Function
ClearError:
Debug.Print "'" & ProcName & "' Run-time error '" _
& Err.Number & "':" & vbLf & " " & Err.Description
Resume ProcExit
End Function
When you assign the values of an Excel range to a variant in VBA you always get a 2D array even if your range is a single column or row i.e. you get an array that is dimensioned as (1 to X,1 to 1). To get an array with dimensions (1 to X) you need to encapsulate the 'get values' code in a worksheetFunction.Transpose() call.
Assuming you have got your array into a 1D form you can then use either an ArrayList or Scripting.Dictionary to simplify compiling unique values. No need to get messyt with array indeces at all.
This is the ArrayList Version
Public Function getUnique(Arr As Variant) As Variant
Dim myList As Object
Set myList = CreateObject("System.collections.Arraylist")
Dim myItem As Variant
For Each myItem In Arr
If myItem <> 0 Then
If Not myList.Contains(myItem) Then
myList.Add myItem
End If
End If
Next
getUnique = myList.toarray
End Function
This is the Scripting.Dictionary version
Public Function getUnique(Arr As Variant) As Variant
Dim myList As Object
Set myList = CreateObject("Scripting.Dictionary")
Dim myItem As Variant
For Each myItem In Arr
If myItem <> 0 Then
If Not myList.exists(myItem) Then
myList.Add myList.Count, myItem
End If
End If
Next
getUnique = myList.Items
End Function
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.
My current code will attempt to copy entire rows based on the column A duplicated name to its respective worksheet using VBA as shown below. But it only works for the 1st duplicated name but not the rest. When i review my code, i realised that my target(at the part for target=Lbound to Ubound part) is always 0 so i was wondering why is it always 0 in this case? Because it suppose to be ranging from 0 to 3?
Sub test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim mycell As Range, RANG As Range, Mname As String, Rng As Range
Dim r As Range, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Sheets(1)
' Build a range (RANG) between cell F2 and the last cell in column F
Set RANG = Range(.Cells(2, "A"), .Cells(.Rows.count, "A").End(xlUp))
End With
' For each cell (mycell) in this range (RANG)
For Each mycell In RANG
Mname = mycell.Value
' If the count of mycell in RANG is greater than 1, then set the value of the cell 1 across to the right of mycell (i.e. column G) as "Duplicate Found"
If Application.WorksheetFunction.CountIf(RANG, mycell.Value) > 1 Then
If dict.count > 0 And dict.Exists(Mname) Then
dict(Mname) = mycell.Row()
Else
dict.Add Mname, mycell.Row()
End If
End If
Next mycell
Dim x As Long, Target As Long, i As Long
Dim CopyMe As Range
'Dim Arr: Arr = Array(Key)
Dim f As Variant
For x = 1 To 4
Set cs = ThisWorkbook.Sheets.Add(After:=Sheets(ThisWorkbook.Sheets.count))
cs.Name = "Names" & x
Next x
'Display result in debug window (Modify to your requirement)
Startrow = 2
For Each Key In dict.Keys
Set Rng = ws.Range("A" & Startrow & ":A" & dict(Key))
'Create 3 Sheets, move them to the end, rename
lr = dict(Key)
v = dict.Keys 'put the keys into an array
'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
'Loop through each row
For i = Startrow To lr
'Create Union of target rows
If ws.Range("A" & i) = v(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, ws.Range("A" & i))
Else
Set CopyMe = ws.Range("A" & i)
End If
End If
Next i
Startrow = dict(Key) + 1
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing And Target = 0 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names1").Range("A1")
Set CopyMe = Nothing
End If
If Not CopyMe Is Nothing And Target = 1 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names2").Range("A1")
Set CopyMe = Nothing
End If
If Not CopyMe Is Nothing And Target = 2 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names3").Range("A1")
Set CopyMe = Nothing
End If
If Not CopyMe Is Nothing And Target = 3 Then
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets("Names4").Range("A1")
Set CopyMe = Nothing
End If
Next Target
Next
End Sub
Main worksheet
In the case of duplicated John name:
In the case of duplicated Alice name
Updated code:
Sub test()
Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Sheet1")
Dim cs As Worksheet
Dim mycell As Range, RANG As Range, Mname As String, Rng As Range
Dim r As Range, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With Sheets(1)
' Build a range (RANG) between cell F2 and the last cell in column F
Set RANG = Range(.Cells(2, "A"), .Cells(.Rows.Count, "A").End(xlUp))
End With
' For each cell (mycell) in this range (RANG)
For Each mycell In RANG
Mname = mycell.Value
' If the count of mycell in RANG is greater than 1, then set the value of the cell 1 across to the right of mycell (i.e. column G) as "Duplicate Found"
If Application.WorksheetFunction.CountIf(RANG, mycell.Value) > 1 Then
If dict.Count > 0 And dict.Exists(Mname) Then
dict(Mname) = mycell.Row()
Else
dict.Add Mname, mycell.Row()
End If
End If
Next mycell
Dim StartRow As Long
StartRow = 2
Dim Key As Variant
Dim lr As Long, v As Variant
For Each Key In dict.Keys
Set Rng = ws.Range("A" & StartRow & ":A" & dict(Key))
lr = dict(Key)
v = dict.Keys 'put the keys into an array
'Create 3 Sheets, move them to the end, rename
'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
'Loop through each row
For i = StartRow To lr
'Create Union of target rows
If ws.Range("A" & i) = v(Target) Then
If Not CopyMe Is Nothing Then '<---object required error at If Not copyme...
Set CopyMe = Union(CopyMe, ws.Range("A" & i))
Else
Set CopyMe = ws.Range("A" & i)
End If
End If
Next i
StartRow = dict(Key) + 1
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
Mname = "Name" & CStr(Target + 1)
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets(Mname).Range("A1")
Set CopyMe = Nothing
End If
Next Target
Next Key
End Sub
Use a dictionary for the start row and another for the end row. It is then straightforward to determine the range of duplicate rows for each name and copy them to a new sheet.
Sub CopyDuplicates()
Dim wb As Workbook, ws As Worksheet
Dim irow As Long, iLastRow As Long
Dim dictFirstRow As Object, dictLastRow As Object, sKey As String
Set dictFirstRow = CreateObject("Scripting.Dictionary") ' first row for name
Set dictLastRow = CreateObject("Scripting.Dictionary") ' last row for name
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")
iLastRow = ws.Range("A" & Rows.Count).End(xlUp).Row
' build dictionaries
For irow = 1 To iLastRow
sKey = ws.Cells(irow, 1)
If dictFirstRow.exists(sKey) Then
dictLastRow(sKey) = irow
Else
dictFirstRow.Add sKey, irow
dictLastRow.Add sKey, irow
End If
Next
' copy range of duplicates
Dim k, iFirstRow As Long, rng As Range, wsNew As Worksheet
For Each k In dictFirstRow.keys
iFirstRow = dictFirstRow(k)
iLastRow = dictLastRow(k)
' only copy duplicates
If iLastRow > iFirstRow Then
Set wsNew = wb.Worksheets.Add(after:=wb.Sheets(wb.Sheets.Count))
wsNew.Name = k
Set rng = ws.Rows(iFirstRow & ":" & iLastRow).EntireRow
rng.Copy wsNew.Range("A1")
Debug.Print k, iFirstRow, iLastRow, rng.Address
End If
Next
MsgBox "Done"
End Sub
I couldn't find a mistake because I didn't want to set up the workbook that would enable me to test your code thoroughly. However, I did read through your code and found that you were very lax on declaring variables. I suggest you enter Option Explicit at the top of your code.
To call a Key a "Key" is asking for trouble. Best practice suggests that you don't use VBA key words as variable names. In the context of your code, For Each Key In Dict.Keys requires Key to be a variant. Being undeclared would make it a variant by default but if it's also a word VBA reserves for its own use confusion might arise.
Another idea is that you might have put a break point on For Target = LBound(v) To UBound(v) - 1. When the code stops there Target will be zero because the line hasn't executed yet. But after the first loop execution will not return to this line. So you might have missed Target taking on a value and the error might be elsewhere. Make sure you place the break point on the first line after the For statement. You might also add Debug.Print LBound(v), UBound(v) before the For statement or check these values in the Locals window.
Below is the section of the code where I added several variable declarations and made an amendment to the code that creates and names the new sheets.
Dim StartRow As Long
StartRow = 2
Dim Key As Variant
Dim lr As Long, v As Variant
For Each Key In Dict.Keys
Set Rng = Ws.Range("A" & StartRow & ":A" & Dict(Key))
lr = Dict(Key)
v = Dict.Keys 'put the keys into an array
'Create 3 Sheets, move them to the end, rename
'Loop through each name in array
For Target = LBound(v) To UBound(v) - 1 '<-------why is Target always 0 here?
'Loop through each row
For i = StartRow To lr
'Create Union of target rows
If Ws.Range("A" & i) = v(Target) Then
If Not CopyMe Is Nothing Then
Set CopyMe = Union(CopyMe, Ws.Range("A" & i))
Else
Set CopyMe = Ws.Range("A" & i)
End If
End If
Next i
StartRow = Dict(Key) + 1
'Copy the Union to Target Sheet
If Not CopyMe Is Nothing Then
Mname = "Name" & CStr(Target + 1)
CopyMe.EntireRow.Copy Destination:=ThisWorkbook.Sheets(Mname).Range("A1")
Set CopyMe = Nothing
End If
Next Target
Next Key
John, I spent an hour working my way through your code - correcting and commenting. I got a real good feeling of how confidence escaped from your mind as you went into the last third of the code. The same thing happened to me. I saw, as you probably did, that the concept was so far off the mark that it is very hard to salvage. So I wrote code that probably does what you want. Please try it.
Sub TransferData()
Dim Src As Variant ' source data
Dim Ws As Worksheet ' variable target sheet
Dim WsName As String
Dim Rl As Long ' last row
Dim R As Long ' row
Dim C As Long ' column
With ThisWorkbook.Sheets("TestData")
' Copy all values between cell A2 and the last cell in column F
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
Src = Range(.Cells(2, "A"), .Cells(Rl, "F")).Value
End With
Application.ScreenUpdating = False
For R = 1 To UBound(Src)
WsName = Trim(Split(Src(R, 1))(0)) ' first word in A2 etc
On Error Resume Next
Set Ws = Worksheets(WsName)
If Err Then
With ThisWorkbook.Sheets
Set Ws = .Add(After:=Sheets(.Count))
End With
Ws.Name = WsName
End If
On Error Goto 0
' append data
With Ws
Rl = .Cells(.Rows.Count, "A").End(xlUp).Row
For C = 1 To UBound(Src, 2)
With .Rows(Rl + 1)
.Cells(C).Value = Src(R, C)
End With
Next C
End With
Next R
Application.ScreenUpdating = True
End Sub
The code doesn't use a dictionary. That's why it is much shorter and much more efficient, too. It just sorts the data directly to different sheets based on what it finds in column A. There is no limit to the number of sheets you might need.
Observe that the sheet on which I had the data is called "TestData" in this code. It should be the one in your project that responded to the moniker Sheets(1), most likely aka ThisWorkbook.Worksheets("Sheet1").
I am trying to get unique values from dynamic F column and store it in an array. I am getting "Object Required error for my code while setting Selection variable to a dynamic range. Please help.
Sub UniqueFilter()
Dim tmp As String
Dim arr() As String
Dim Selection As Range
Dim lrow As Long
Dim str As String
Dim cell As Range
Dim sht As Worksheet
Set sht = ThisWorkbook.Worksheets("14Feb19")
sht.Activate
'Set Selection = sht.Range(sht.Cells(1, 6), sht.Cells(Rows.Count, 6).End (xlUp)).Select
lrow = shData.Range("F" & Rows.Count).End(xlUp).Row
Set Selection = sht.Range("F2:F" & lrow).Select
If Not Selection Is Nothing Then
For Each cell In Selection
If (cell <> "") And (InStr(tmp, cell) = 0) Then
tmp = tmp & cell & "|"
End If
Next cell
End If
If Len(tmp) > 0 Then tmp = Left(tmp, Len(tmp) - 1)
arr = Split(tmp, "|")
End Sub
You can achieve your goal without having to use Selection at all.
Just copy the range content and transpose it into an array:
Sub UniqueFilter()
Dim arr() As String
Dim tmp As Variant
Dim lrow As Long
Dim sht As Worksheet
Dim index As Integer
Dim count As Integer
Set sht = ThisWorkbook.Worksheets("14Feb19")
sht.Activate
lrow = sht.Range("F" & Rows.count).End(xlUp).Row
'Copying and trasposing selected Range
tmp = Application.Transpose(sht.Range("F2:F" & lrow).Value)
'Cleaning from temp array all empty values
count = 1
For index = 1 To UBound(tmp, 1) - LBound(tmp, 1) + 1
ReDim Preserve arr(1 To count)
If tmp(index) <> "" Then
arr(count) = tmp(index)
count = count + 1
End If
Next
End Sub
(special thanks to #Nathan_Sav, who helped simplifying the code)
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