i need help with dictionary understanding so im trying with something simple. I have code that search and delete duplicate value.
I store dict Key as People and item as ID's. Idea is to loop to cell range with data, find duplicate values delete them but concatenate Item(ID's).
How can i get item from Dictionary to range cell with ID's and concatenate values? I wolud appreciate and help, link, tutorial, suggestion
Code so far:
Option Explicit
Sub DictionaryTest()
Dim dict As Scripting.Dictionary
Dim rowCount As Long
Dim People As String
Dim ID As Integer
Dim item As Variant
Set dict = New Scripting.Dictionary
rowCount = Cells(Rows.Count, "E").End(xlUp).Row
'Debug.Print rowCount
Do While rowCount > 1
People = Sheet2.Cells(rowCount, "E").Value
ID = Sheet2.Cells(rowCount, "D").Value
If dict.Exists(People) Then
'Sheet2.Rows(rowCount).EntireRow.Delete
Else
dict.Add People, ID
End If
rowCount = rowCount - 1
Loop
End Sub
Thank you!
Instead of storing the ID value in the dictionary, you can reference the ID cell and concatenate the values there.
Dim idCell As Range, r As Long
'...
'...
For r = rowCount to 2 Step - 1
People = Sheet2.Cells(rowCount, "E").Value
Set idCell = Sheet2.Cells(rowCount, "D")
If dict.Exists(People) Then
With dict(People) '<< first id cell...
.Value = .Value & ";" & IdCell.Value
End With
Sheet2.Rows(rowCount).EntireRow.Delete 'get id *before* delete ;-)
Else
dict.Add People, idCell 'reference first ID cell (the cell
' itself, not the cell value)
End If
Next r
Please see if this works for you.
Sub RemDupVal()
Dim t As Range, x As Range, z As Range
Set x = Range("A2:A7") 'ID
Set z = Range("B2:B7") 'Item
Set t = Cells(2, Cells(1, 16383).End(xlToLeft).Column + 1).Resize(x.Rows.Count)
t = x.Parent.Evaluate(x.Address & "&" & z.Address) 'assuming evaluate character limit is met
Union(x, t).Select
selection.RemoveDuplicates t.Column, xlNo
t.ClearContents: Cells(1, 1).Select
End Sub
I'm working on this code and update it a bit. I see that I Immediate window Items from duplicate dictionary are concatenate so code work exactly what I want but I don't know how I can get that value concatenate in cells. In dictionary keys are People and Item are ID
This is best result I have in many code testing.
Sub DictTest()
Dim dict As Scripting.Dictionary
Dim rowsCount As Long
Dim People As String, id As Integer
Set dict = New Scripting.Dictionary
rowsCount = Cells(Rows.Count, "D").End(xlUp).Row
People = Sheet2.Cells(rowsCount, "D").Value
Do While rowsCount > 1
People = Sheet2.Cells(rowsCount, "D").Value
id = Sheet2.Cells(rowsCount, "C")
'if duplicate value is found then concatenate Item value
If dict.Exists(People) Then
dict(People) = dict(People) & "," & " " & id
Debug.Print dict(People) '-> in immediate window shows concatenate Item values
Sheet2.Rows(rowsCount).EntireRow.Delete
Else
dict.Add People, id
End If
rowsCount = rowsCount - 1
Loop
End Sub
Related
I have my column B, starting from cell 2 (because of the header) containing codes of type String. I would like to get a list of these codes. However, these codes are repeated a number of times. So I would like to loop through my column B and add to my array of codes whenever a new one is encountered, if that makes sense.
Here is my code. How can this be done ? Thanks in advance.
Sub List()
Dim listCodes() As String
With Worksheets("My sheet)
nbr_lines = .Rows.Count
Dim i As Long
val_old = .Cells(2, 2).Value
listCodes(1) = val_old
For i = 2 To nbr_lines
val_new = .Cells(i + 1, 2).Value
While val_old = val_new
val_old = val_new
Wend
listCodes(i) = val_new
val_old = val_new
Next i
End With
End Sub
As mentioned in my comment, I'd suggest a dictionary. Drop the entire column into an array for speedy processing first, then throw it all in the dictionary:
Sub List()
Dim listCodes() As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim nbr_lines As Long
With Worksheets("My sheet")
'Get last used line and throw values in array;
nbr_lines = .Cells(.Rows.Count, 2).End(xlUp).Row
listCodes = .Range("B2:B" & nbr_lines).Value
'Loop array instead of cells for speed. Add all unique items into dictionary;
For Each el In listCodes
dict(el) = ""
Next
'Add the content of the dictionary to the sheet;
.Range("C2").Resize(dict.Count).Value = Application.Transpose(dict.Keys)
End With
End Sub
Note: This can also be achieved outside of VBA through easy formulae like the UNIQUE() function.
You can use dictionary approach. Below sub will copy only unique items to column D. Modify codes as your need.
Public Sub CopyUniqueOnly()
Dim i As Long
Dim currCell As Range, dict As Object
Set dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet1")
For Each currCell In .Range("B2", .Cells(.Rows.Count, 2).End(xlUp))
If Not dict.exists(currCell.Value) And Not IsEmpty(currCell) Then
dict.Add currCell.Value, currCell.Value
End If
Next currCell
End With
Range("D2").Resize(dict.Count) = Application.Transpose(dict.keys)
End Sub
I'm looking to have a VBA macro loop through a range of cells and populate a User Form Listbox with each unique value that it finds. The range of values is in column "L". I have that figured out, however the stipulation I'm having trouble coding is that I also need it to look at the value in Column "D" as well, and to NOT add the value in column "L" to the Listbox if it finds a value in Column "D".
I've included a screenshot of what the worksheet would look like and the desired output would be. Any help would be greatly appreciated!
Private Sub UserForm_Initialize()
Dim Dict As Object
Dim Key As Variant
Dim LastRow As Long
Dim Relay As Range
With Sheets("Score Sheet")
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
Set Dict = CreateObject("Scripting.Dictionary")
For Each Relay In .Range("L2:L" & LastRow)
If IsEmpty(Range("D" & Relay).Value) = True Then
If Relay.Value <> "" Then
If Not Dict.exists(Relay.Value) Then
Dict.Add Relay.Value, 1
End If
End If
End If
Next Relay
End With
For Each Key In Dict.keys
lstRelayNumber.AddItem Key
Next Key
End Sub
Private Sub UserForm_Initialize()
Dim Dict As Object
Dim LastRow As Long
Dim Relay As Range, vL, vD
Set Dict = CreateObject("Scripting.Dictionary")
With Sheets("Score Sheet")
LastRow = .Cells(.Rows.Count, "L").End(xlUp).Row
For Each Relay In .Range("L2:L" & LastRow).Cells
vL = Relay.Value 'Column L value
vD = .Range("D" & Relay.Row).Value 'Column D value
If Len(vL) > 0 and Len(vD) = 0 Then
If Not Dict.exists(vL) Then
Dict.Add vL, 1
lstRelayNumber.AddItem vL 'can add to the list in this loop...
End If
End If
Next Relay
End With
End Sub
Im trying to find way how to use Dictionary to delete duplicate values and concatenate items values in cells.
Code belowe is doing what i imagine but I can see it in immediate window (Debug.Print dict(People).
Item (ID) of duplicate values of dictionary Keys(People) are concatenate with comma but i dont know how to extract that Items to cell.
So idea for VBA to do is find duplicate value and concatenate ID values and delete duplicate.
Thank you!
Option Explicit
Sub DictionaryTest()
Dim dict As Scripting.Dictionary
Dim rowCount As Long
Dim People As String
Dim ID As Integer
Dim item As Variant
Set dict = New Scripting.Dictionary
rowCount = Cells(Rows.Count, "E").End(xlUp).Row
'Debug.Print rowCount
Do While rowCount > 1
People = Sheet2.Cells(rowCount, "E").Value
ID = Sheet2.Cells(rowCount, "D").Value
If dict.Exists(People) Then
'Sheet2.Rows(rowCount).EntireRow.Delete
Else
dict.Add People, ID
End If
rowCount = rowCount - 1
Loop
End Sub
Try this adapted code, please:
Sub DictionaryTest()
Dim dict As New Scripting.Dictionary
Dim rowCount As Long, i As Long
Dim People As String
Dim ID As Integer
Dim sh As Worksheet
Set sh = Sheet2
rowCount = sh.cells(Rows.count, "D").End(xlUp).Row
For i = 2 To rowCount
People = sh.cells(i, "D").Value
ID = sh.cells(i, "C").Value
If dict.Exists(People) Then
dict(People) = dict(People) & "," & ID
Else
dict.Add People, ID
End If
Next i
sh.Range("F2").Resize(dict.count).Value = WorksheetFunction.Transpose(dict.Items)
sh.Range("G2").Resize(dict.count).Value = WorksheetFunction.Transpose(dict.Keys)
End Sub
I want to populate unique values into combobox.
My sheet details
Code:
Private Sub ComboBoxscname_DropButtonClick()
With Worksheets("A1")
ComboBoxscname.List = .Range("B2:B" & .Cells(.Rows.Count, "A").End(xlUp).Row).Value
End With
End Sub
I have highlighted with yellow which are duplicated for column "B" and should be displayed only once in combobox.
Another solution I have but getting error when selecting specific sheet name.
Sub ComboBoxscnameList()
Dim LR As Long
Dim ctrl As Object
'Set ctrl = Sheets("A1").Select
LR = Cells(Rows.Count, "B").End(xlUp).Row
ctrl.List() = CreateArray(Range("B2:B" & LR))
End Sub
'creates an array from a given range
'ignores blanks and duplicates
Function CreateArray(r As Range)
Dim col As New Collection, c As Range, TempArray(), i As Long
'for each cell in range r
For Each c In r
On Error Resume Next
col.Add c.Value, CStr(c.Value)
If Err.Number = 0 And Trim(c) <> "" Then
ReDim Preserve TempArray(i)
TempArray(i) = c.Value
i = i + 1
End If
Err.Clear
Next
CreateArray = TempArray
Erase TempArray
End Function
Private Sub ComboBoxscname_DropButtonClick()
Call ComboBoxscnameList
End Sub
The easiest way to save a unique set of values from a Column or Range is by using a Dictionary. You loop though your cells in column B, and check if each one is already in the Dictionary keys, the syntax is Dict.Exists("your_parameters").
You can read more about using Dictionary HERE.
Review the modified code below, you want to add it to your UserForm_Initialize() event.
Modified Code
Private Sub UserForm_Initialize()
Dim i As Long, ArrIndex As Long, LastRow As Long
Dim Dict As Object, Key As Variant
Dim HSNArr() As String
Application.ScreenUpdating = False
' us a Dictionary, and save unique Eco-System as array
Set Dict = CreateObject("Scripting.Dictionary")
With ThisWorkbook.Worksheets("Sheet2") ' <-- modify to your sheet's name
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
ReDim HSNArr(1 To LastRow) ' redim HSN array >> will optimize size later
ArrIndex = 1
For i = 2 To LastRow
If Not Dict.Exists(.Range("B" & i).Value2) And Trim(.Range("B" & i).Value2) <> "" Then ' make sure not in Dictionary and ignore empty cells
Dict.Add .Range("B" & i).Value2, .Range("B" & i).Value2 ' add current HSN
HSNArr(ArrIndex) = .Range("B" & i).Value2
ArrIndex = ArrIndex + 1
End If
Next i
End With
ReDim Preserve HSNArr(1 To ArrIndex - 1) ' resize to populated size of Array
Application.ScreenUpdating = True
With Me.ComboBoxscname
.Clear ' clear previous combo-box contents
For i = 1 To UBound(HSNArr) ' loop through array, add each unique HSN to Combo-Box
.AddItem HSNArr(i)
Next i
' show default value
.Value = HSNArr(1)
End With
End Sub
I have column A that has all existing categories, new categories are listed in column C. I'm trying to determine how to take these new categories, and add them to column "a" if they aren't already in column A. In the example the new categories in column C are added to column A even if there are already in column A. I would also need range("a1") in the if-then line to be a dynamic range since new categories will be added as the code runs. Some constructive criticism would be greatly appreciated as well to help me in the future.
Sub newcategory()
Dim newcatcount As Integer
Dim i As Integer
newcat = Range("c100000").End(xlUp).Row
For i = 1 To newcat
If Cells(i, 3).Value <> Range("a1") Then
Cells(i, 3).Select
Selection.copy
Range("a100000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste
End If
Next
End Sub
Please give this a try...
Sub AddNewCategories()
Dim lrA As Long, lrC As Long, i As Long, j As Long
Dim x, y, z(), dict
lrA = Cells(Rows.Count, 1).End(xlUp).Row
lrC = Cells(Rows.Count, 3).End(xlUp).Row
'Array to hold the categories in column A starting from Row1, assuming the categories start from A1. If not, change it accordingly.
x = Range("A1:A" & lrA).Value
'Array to hold the new categories in column C starting from Row1, assuming the categories start from C1. If not, change it accordingly.
y = Range("C1:C" & lrC).Value
Set dict = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(x, 1)
dict.Item(x(i, 1)) = ""
Next i
For i = 1 To UBound(y, 1)
If Not dict.exists(y(i, 1)) Then
dict.Item(y(i, 1)) = ""
j = j + 1
ReDim Preserve z(1 To j)
z(j) = y(i, 1)
End If
Next i
If j > 0 Then
Range("A" & lrA + 1).Resize(j).Value = Application.Transpose(z)
End If
Set dict = Nothing
End Sub
you could use excel built in RemoveDuplicates() function, as follows (mind the comments):
Option Explicit
Sub newcategory()
Dim newcat As Range
With Worksheets("Categories") ' change "Categories" to your actual sheeet name
Set newcat = .Range("C1", .Cells(.Rows.Count, 3).End(xlUp)) ' get the range of all nwe categories in reference sheet column C from row 1 down to last not empty one
.Cells(.Rows.Count, 1).End(xlUp).Resize(newcat.Rows.Count).Value = newcat.Value ' append new categories values below existing categories in column A
.Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).RemoveDuplicates Columns:=Array(1), Header:=xlNo ' remove duplicates
End With
End Sub