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
Related
The below code basically looks at a source sheet on workbook open, takes the values from a range and loops through adding each value to a combobox.
What I want to do is include some code to ensure only unique values, i.e. no dupes, are added.
Any ideas how I can get that working?
Thanks!
Private Sub Workbook_Open()
Dim wb As Workbook
Set wb = ThisWorkbook
Dim Home As Worksheet
Dim Datasource As Worksheet
'Define Variables and dropdown object
Dim LastRow As Long
Dim MIDCell As Range
Dim ComboMID As ComboBox
Set Home = ActiveSheet
Set Home = Worksheets("UPDATER")
Set Datasource = wb.Sheets("LaunchCodes")
'asign dropdown object to combobox
Set ComboMID = Home.OLEObjects("ComboBox1").Object
'Empty the combobox currnetly to avoid duplicating content
ComboMID.Clear
'With and For loop to put all values in games launch code column, ignoring any blanks, into combobox
With Datasource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
For Each MIDCell In .Range("D2:D1000" & LastRow)
If MIDCell.Value <> "" Then
ComboMID.AddItem MIDCell.Value
End If
Next
End With
End Sub
The code below avoids looping through cells in a worksheet because it's slow. Actually, that process can be sped up by reading the list into a variable (as, in fact, my code also does) but using Excel's own RemoveDuplicates method appears more efficient.
Private Sub Workbook_Open()
' 155
Dim Wb As Workbook
Dim ComboMid As ComboBox
Dim TmpClm As Long ' number of temporary column
Dim Arr As Variant ' unique values from column D
Set Wb = ThisWorkbook
With Wb.Worksheets("UPDATER")
Set ComboMid = .OLEObjects("ComboBox1").Object
With .UsedRange
TmpClm = .Column + .Columns.Count
End With
End With
With Wb.Sheets("LaunchCodes")
' create a copy of your data (without header) in an unused column
.Cells(2, "D").CurrentRegion.Copy .Cells(1, TmpClm)
.Cells(1, TmpClm).CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlNo
Arr = .Cells(1, TmpClm).CurrentRegion.Value
.Columns(TmpClm).ClearContents
End With
With ComboMid
.List = Arr
.ListIndex = 0 ' assign first list item to Value
End With
End Sub
You don't need to clear the combo box in the above code because replacing the List property with a new array automatically removes whatever it was before.
Unique to ComboBox
To learn about the combo box study this.
You can replace the code after the line Set ComboMID = Home.OLEObjects("ComboBox1").Object with the following snippet:
Dim rng As Range
With DataSource
LastRow = .Cells(.Rows.Count, "D").End(xlUp).Row
Set rng = .Range("D2:D" & lastrow)
End With
Dim Unique As Variant
Unique = getUniqueFromRange(rng)
If Not IsEmpty(Unique) Then
ComboMID.List = Unique
End If
which uses the following function:
Function getUniqueFromRange( _
rng As Range) _
As Variant
If rng Is Nothing Then
Exit Function
End If
Dim Data As Variant
If rng.Cells.CountLarge > 1 Then
Data = rng.Value
Else
ReDim Data(1 To 1, 1 To 1)
Data(1, 1) = rng.Value
End If
cCount = UBound(Data, 2)
Dim cValue As Variant
Dim i As Long
Dim j As Long
With CreateObject("Scripting.Dictionary")
.CompareMode = vbTextCompare
For i = 1 To UBound(Data, 1)
For j = 1 To cCount
cValue = Data(i, j)
If Not IsError(cValue) And Not IsEmpty(cValue) Then
.Item(cValue) = Empty
End If
Next j
Next i
If .Count > 0 Then
getUniqueFromRange = .Keys
End If
End With
End Function
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
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 created a macro file with Forms and Word to Excel.
In this coding fewthings are not working as per my expectation.
Get unique Employee Name from Excel data base.
I want to add unique employee names from excel database and get is saved in a sheet. After that those values to be added to list box. Here i cannot define a range like "A1:A10".. I want to choose the data from A1 to end data.
If for each cell approach will not work, please help in do while approach
I need help in defining the range and code given below
ListEmployeeName.Clear
For Each cell In Worksheets("SunEmployeeDetails").Range("A1").End(xlDown)
ListEmployeeName.AddItem (cell.Value)
Next
ListEmployeeName.Value = Worksheets("SunEmployeeDetails").Range("A1")
End Sub
Find Last Row and then define your range Range("A1:A" & LastRow)
You can also find the last row and loop through the range using a For loop. Also to get unique Employee Name, you can use On Error Resume Next with a Collection as shown below. I have commented the code below so you should not have a problem understanding it. But if you do then simply ask.
Is this what you are trying? (Untested).
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, i As Long
Dim col As New Collection
Dim itm As Variant
Set ws = Worksheets("SunEmployeeDetails")
With ws
'~~> Find Last row
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
'~~> Loop through the range and add it to the unique
'~~> collection using "On Error Resume Next"
For i = 1 To lRow
On Error Resume Next
col.Add .Range("A" & i).Value, CStr(.Range("A" & i).Value)
On Error GoTo 0
Next i
End With
ListEmployeeName.Clear
'~~> add the itme from collection to the listbox
For Each itm In col
ListEmployeeName.AddItem itm
Next itm
End Sub
Here is my take on it, techniques taken from here:
Methode 1: Using a dictionary
Dim lr As Long, x As Long
Dim arr As Variant
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
With Sheet1 'Change accordingly
'Find the last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
arr = .Range("A1:A" & lr).Value
End With
'Loop through memory and fill dictionary
For x = LBound(arr) To UBound(arr)
dict(arr(x, 1)) = 1
Next x
'Add array to Listbox
Me.ListEmployeeName.List = dict.Keys
Methode 2: Using Evaluation
Dim lr As Long
Dim arr As Variant
With Sheet1 'Change accordingly
'Find the last used row
lr = .Cells(.Rows.Count, 1).End(xlUp).Row
'Get array of unique values
arr = Filter(.Evaluate("TRANSPOSE(If(Row(A1:A" & lr & ")<>MATCH(A1:A" & lr & ",A1:A" & lr & ",0),""|"",A1:A" & lr & "))"), "|", False)
'Add array to Listbox
Me.ListEmployeeName.List = arr
End With
I have a worksheet that I need to split out into new ones by column C values. There are 8 values, so I'll need 8 worksheets. Each value has about 2-5000 corresponding rows, so this script isn't ideal because it prints row-by-row.
Sub SplitData()
Const iCol = 3 ' names in second column (B)
Const sRow = 2 ' data start in row 2
Dim wshSource As Worksheet
Dim wshTarget As Worksheet
Dim i As Long
Dim lRow As Long
Dim lngTargetRow As Long
Application.ScreenUpdating = False
Set wshSource = Sheets(1)
lRow = wshSource.Cells(wshSource.Rows.Count, iCol).End(xlUp).Row
For i = sRow To lRow
If wshSource.Cells(i, iCol).Value <> wshSource.Cells(i - 1, iCol).Value Then
Set wshTarget = Worksheets.Add(After:=Worksheets(Worksheets.Count))
wshTarget.Name = wshSource.Cells(i, iCol).Value
wshSource.Rows(sRow - 1).Copy Destination:=wshTarget.Cells(1, 1)
lngTargetRow = 2
End If
wshSource.Rows(i).Copy Destination:=wshTarget.Cells(lngTargetRow, 1)
lngTargetRow = lngTargetRow + 1
Next i
Application.ScreenUpdating = True
End Sub
How would I change this up to print each value block (column C) to each worksheet instead of every row (i) individually? Would I need to implement auto-filtering by column C values and do a loop that way?
Try this out, as you well pointed, filtering would be the fastest way here:
Option Explicit
Sub Test()
Dim uniqueValues As Object
Set uniqueValues = CreateObject("Scripting.Dictionary")
Dim i As Long
With ThisWorkbook.Sheets("MainSheet") 'change MainSheet to the name of the sheet containing the data
'First let's store the unique values inside a dictionary
For i = 2 To .UsedRange.Rows.Count 'this will loop till the last used row
If Not uniqueValues.Exists(.Cells(i, 3).Value) Then uniqueValues.Add .Cells(i, 3).Value, 1
Next i
'Now let's loop through the unique values
Dim Key As Variant
For Each Key In uniqueValues.Keys
.UsedRange.AutoFilter Field:=3, Criteria1:=Key 'Filter column C by the value in the key
ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count) 'add a new sheet
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = Key 'change the name of the new sheet to the key's
.UsedRange.SpecialCells(xlCellTypeVisible).Copy ThisWorkbook.Sheets(Key).Range("A1") 'copy the visible range after the filter to the new sheet
Next Key
End With
End Sub