i have a simple Excel/VBA problem:
What i want to create is a (single-select) ListBox where I want to show unique values of Data i have on a different worksheet.
So far I have a ListBox like this:
And a named selection of the data i want to show:
I used a formula like this and used that as the input for the ListBox.
The formula: =BEREICH.VERSCHIEBEN(TopicData!$C$1;1;0;ANZAHL2(TopicData!$C:$C)-1;1)
Now my question is: How can i get the ListBox to show only unique values? I am familiar with vba, so a solution including this would be totally fine. In fact I already tried to remove duplicate entries in vba, whenever there is a change to the ListBox, but for some reason nothing seems to work.
Here is my vba script where I tried to solve this:
unfortunatley I always get a "Error 400" when I trie to call RemoveItem on the ListBox.
' ...
' filter listbox content so only unique values remain
Dim i As Integer
' find duplicates
Dim inList As New Collection
Dim indexesToRemove As New Collection
For i = availableTopicsListBox.ListCount - 1 To 1 Step -1
If CollectionContains(inList, availableTopicsListBox.List(i)) Then
' if it is already in the list, remove it
indexesToRemove.Add i
Else
inList.Add availableTopicsListBox.List(i)
End If
Next i
' remove duplicates
Dim j As Integer
For j = indexesToRemove.count To 1 Step -1
availableTopicsListBox.RemoveItem (indexesToRemove(j))
Next j
'...
The code below will use the Dictionary to store only unique values from column C (in "TopicData" worksheet), and then populate availableTopicsListBox listbox with only the unique values inside the Dictionary.
Code
Option Explicit
Private Sub UserForm_Activate()
Dim Dict As Object
Dim Key As Variant
Dim LastRow As Long
Dim C As Range
With Sheets("TopicData") '<-- I think this is your sheet's name
' find last row with data in column "C"
LastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
Set Dict = CreateObject("Scripting.Dictionary")
For Each C In .Range("C1:C" & LastRow)
If C.Value <> "" Then ' <-- skip empty cells
If Not Dict.exists(C.Value) Then
Dict.Add C.Value, 1
End If
End If
Next C
End With
' loop through all unique keys, and add them to the listbox
For Each Key In Dict.keys
availableTopicsListBox.AddItem Key
Next Key
End Sub
Related
Im trying to check if records in one column of the table matches atleast one value of the ArrayList and if yes show those records who match in the next form
I have ArrayList full of strings and i dont know how to check and insert records from table to textboxes in next form, where atleast one of the records data of one column matches one value in ArrayList.
This doesn't work:
Public Sub Command42_Click()
Dim NotTrained As ArrayList
Set NotTrained = New ArrayList
NotTrained.Add "value1"
NotTrained.Add "value2"
DoCmd.OpenForm "form_name", WhereCondition:=NotTrained.Contains(handover_No) = True
End Sub
I dont know if i am even able to do this in WhereCondition, or i need to open the next form and insert the data in the textboxes in the NextForm.Load() Sub.
In the next form the textboxes have source control set to the columns in the table from which i want the records to be taken.
Part of the solution is :
You can loop through the range cells and look for existing ones in the Arraylist like this
Public Sub Command42_Click()
Dim NotTrained As ArrayList
Set NotTrained = New ArrayList
Dim I As Long, LR As Long
Dim rng As Range
NotTrained.Add "value1"
NotTrained.Add "value2"
LR = ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
Set rng = Range("A1")
For I = 0 To LR
If NotTrained.IndexOf(rng.Offset(I, 0).Value, 0) = -1 Then
' the value is not in ArrayList
' Do Something
Else
' the value is in ArrayList
' Do Something Else
End If
Next I
'DoCmd.OpenForm "form_name", WhereCondition:=NotTrained.Contains(handover_No) = True
End Sub
I do not know what the structure of your form is, so I can not advise you how to fill it out.
I have seen multiple codes regarding this topic but I can't seem to understand it.
For instance, if I have a column that records people names, I want to record all unique names into the array.
So if I have a column of names
David
Johnathan
Peter
Peter
Peter
Louis
David
I want to utilize VBA to extract unique names out of the column and place it into an array so when I call the array it would return these results
Array[0] = David
Array[1] = Johnathan
Array[2] = Peter
Array[3] = Louis
Despite a Collection being mentioned and being a possible solution, it is far more efficient to use a Dictionary as it has an Exists method. Then it's just a matter of adding the names to the dictionary if they don't already exist, and then extracting the keys to an array when you're done.
Note that I've made the name comparisons case-sensitive, but you can change that if necessary, to case-insensitive.
Option Explicit
Sub test()
'Extract all of the names into an array
Dim values As Variant
values = Sheet1.Range("Names").Value2 'Value2 is faster than Value
'Add a reference to Microsoft Scripting Runtime
Dim dic As Scripting.Dictionary
Set dic = New Scripting.Dictionary
'Set the comparison mode to case-sensitive
dic.CompareMode = BinaryCompare
Dim valCounter As Long
For valCounter = LBound(values) To UBound(values)
'Check if the name is already in the dictionary
If Not dic.Exists(values(valCounter, 1)) Then
'Add the new name as a key, along with a dummy value of 0
dic.Add values(valCounter, 1), 0
End If
Next valCounter
'Extract the dictionary's keys as a 1D array
Dim result As Variant
result = dic.Keys
End Sub
use Dictionary object and build a Function that returns your array
Function GetUniqeNames(myRng As Range) As Variant
Dim cell As Range
With CreateObject("Scripting.Dictionary") ' instantiate and reference a Dictionary object
For Each cell In myRng ' loop through passed range
.Item(cell.Value2) = 1 ' store current cell name into referenced dictionary keys (duplicates will be overwritten)
Next
GetUniqeNames = .keys ' write referenced dictionary keys into an array
End With
End Function
that you can exploit in your main code as follows
Sub main()
Dim myArray As Variant
With Worksheets("mysheet") ' change "mysheet" to your actual sheet name
myArray = GetUniqeNames(.Range("A1", .Cells(.Rows.Count, 1).End(xlUp))) ' this will take the referenced sheet column A range from row 1 down to last not empty one
End With
End Sub
Is this a VBA question or a question about programming logic? Use a loop on the column with the data. Check each name against the list of existing data items. If it exists in the list, move on the the next name. If it does not exist in the list, add it.
The "list" is a concept, not a concrete tool. It can be a VBA dictionary, if you are comfortable using that. Or it can be a VBA array, which may not perform as fast as a dictionary, but may be more familiar.
Then again, if you add the data to the Excel Data Model, you can use the Distinct aggregation of a pivot table to list out the unique values.
Without more background it's hard to tell if VBA or Data Model is your best approach. Many VBA solutions get created because people are not aware of Excel's capabilities.
You could use Excel functionality like that.
Sub UniqueNames()
Dim vDat As Variant
Dim rg As Range
Dim i As Long
Set rg = Range("A1:A7")
rg.RemoveDuplicates Columns:=Array(1), Header:=xlNo
With ActiveSheet
vDat = WorksheetFunction.Transpose(.Range("A1:" & .Range("A1").End(xlDown).Address))
End With
For i = LBound(vDat) To UBound(vDat)
Debug.Print vDat(i)
Next i
End Sub
Code is based on your example data, i.e. I put your data into column 1. But the code will also alter the table. If you do not want that you have to use other solutions or put the data beforehand in a temporary sheet.
If you dont want to use "Scripting.Dictionary" and your excel does not have Worksheet.unique(...) like mine
Public Function IsInArray(stringToBeFound As String, arr As Variant) As Boolean
If UBound(arr) >= 0 Then
IsInArray = Not IsError(Application.Match(stringToBeFound, arr, 0))
Else
IsInArray = False
End If
End Function
Public Function GetUniqueValuesFromColumn(ws As Worksheet, sourceColNum As Long, Optional firstRow As Long = 2) As Variant
Dim val As String
Dim i As Long
Dim arr() As Variant
arr = Array()
For i = firstRow To ws.Cells(Rows.Count, sourceColNum).End(xlUp).Row
val = ws.Cells(i, sourceColNum)
If Not IsInArray(val, arr) Then
ReDim Preserve arr(UBound(arr) + 1)
arr(UBound(arr)) = val
End If
Next i
GetUniqueValuesFromColumn = arr
End Function
Then call it like GetUniqueValuesFromColumn(ThisWorkbook.Worksheets("SomeList"), 1)
I have a template with a set number of columns (170) and title headers (row 1 cell name's). This is always the same, until users add columns in between (they're instructed not to change headers). The idea is to make it tamperproof as far as the adding of columns is involved.
I'd like to make variables to hold some of the headers (with the capacity to hold all) and check these with the template to find out the column number (in a loop I reckon). It's probably wisest to make a function to call upon it?
Dim ColHeader1Str as string 'literal row 1, column 1 value (which is always
'the same string and position in the template)
Dim iColHeader1 as integer 'holds the (to be set) value of the column number
Set ColHeader1Str = "ColHeader1"
Now I'd like a loop where it loops trough all the columns (last column = 200) and checks to see what the column number is that matches the ColHeader1Str and store this in the iColHeader1
So something like:
Function find_columnNmbr
Dim i As Integer
For i = 1 To 200 Step 1
If 'ColHeader1Str matches actual column header name
'set found integer as iColHeader1 and so forth
Exit For
End If
Next
End Function`
I know I'm missing a few steps and I'm hoping you guys can help me out.
Update: The template has set column headers. When users interact with it a result could be that columns shift position, or they add more. I have a workbook that needs to load data out of the user's altered template.
I.E. The template has columns 1, 2, 3, 4 and the names are column1, column 2 etc. A user ads a random column so now there are 5. The loop needs to loop through the names of the column headers and identify the column number of the original template columns 1, 2 etc based on a string variable with the original names, which I've hard coded beforehand. These are public constants.
What function LookForHeaders do: input a string, then search for the string in usersheet.range(1:1). If it is found, return the column number of that cell, otherwise it returns 0.
Private Function LookForHeaders(ByVal headerName As String) As Long
Dim rng As Range
Dim userSheet As WorkSheet
Set userSheet = 'userSheet here'
On Error GoTo NotFound
LookForHeaders = userSheet.Range("1:1").Find(headerName).Column
Exit Function
NotFound:
LookForHeaders = 0
End Function
Private Sub Test()
Dim rng As Range
Dim template As WorkSheet
Set template = 'template here'
For Each rng In template.Range(Cells(1,1), Cells(1,200))
iColHeader1 = LookForHeaders(rng.Value)
'Do something with iColHeader1
Next rng
End Sub
Not sure what your looking for but here is example
Option Explicit
Public Sub Example()
Dim LastCol As Long
Dim i As Long
LastCol = ActiveSheet.UsedRange.Columns(ActiveSheet.UsedRange.Columns.Count).Column
For i = 1 To LastCol
If Cells(i) = "Name" Then
Debug.Print Cells(i).Address
End If
Next
End Sub
I have a workbook in which there are 5 sheets :
prize
volatility
size
value
growth
These five sheets have a ticker list (stocks name on index) in columns along with the dates . After every three months a new ticker list comes as a result of rebalancing for e.g. PRIZE sheet is having 2 rebalances so 2 ticker lists and SIZE sheet is having 4 rebalances so 4 ticker lists, so all these ticker lists are presented in the five different sheets. I want to make a macro which picks distinct unique values from these lists and paste it in another sheet in one column.
This will require a reference to the Microsoft Scripting Runtime. Go to the VB Editor, then Tools, References and select it from there.
After that, paste this code in a proc and see if it gets you over the line. It'll certainly push your knowledge in a new direction - dictionaries and arrays are amazing things in the right hands and utterly doom-laden in the wrong hands. You've been warned...!
Dim dctUniqueTickers As Dictionary
Dim dctTickerLocations As Dictionary
Dim arrCurrentTickerRange As Variant
Dim arrTickerOutput As Variant
Dim varSheetNames As Variant
Dim lngDctCounter As Long
Dim lngRowCounter As Long
Dim lngColCounter As Long
Dim lngAreaCounter As Long
' Set up the ticker location range(s)
Set dctTickerLocations = New Dictionary
With dctTickerLocations
.Add "prize", Application.Union(ThisWorkbook.Worksheets("prize").Range("A:A"), _
ThisWorkbook.Worksheets("prize").Range("C:C"))
.Add "size", Application.Union(ThisWorkbook.Worksheets("size").Range("A:A"), _
ThisWorkbook.Worksheets("size").Range("E:E"), _
ThisWorkbook.Worksheets("size").Range("F:F"), _
ThisWorkbook.Worksheets("size").Range("H:H"))
End With
' Populate the destination dictionary
Set dctUniqueTickers = New Dictionary
For Each varSheetNames In dctTickerLocations.Keys
' Looping through the keys (the worksheet names), pick up the associated range(s)
' - there may be multiple areas to consider
For lngAreaCounter = 1 To dctTickerLocations(varSheetNames).Areas.Count
arrCurrentTickerRange = dctTickerLocations(varSheetNames).Areas(lngAreaCounter)
For lngRowCounter = LBound(arrCurrentTickerRange, 1) To UBound(arrCurrentTickerRange, 1)
For lngColCounter = LBound(arrCurrentTickerRange, 2) To UBound(arrCurrentTickerRange, 2)
If LenB(arrCurrentTickerRange(lngRowCounter, lngColCounter)) > 0 Then
If Not dctUniqueTickers.Exists(arrCurrentTickerRange(lngRowCounter, lngColCounter)) Then
' Ticker not found within the dictionary, so add it
dctUniqueTickers.Add arrCurrentTickerRange(lngRowCounter, lngColCounter), arrCurrentTickerRange(lngRowCounter, lngColCounter)
End If
End If
Next
Next
Next
Next
If dctUniqueTickers.Count > 0 Then
lngDctCounter = 0
' Now output
ThisWorkbook.Worksheets("OutputSheet").Range("A1").Value = "Unique tickers"
For Each arrTickerOutput In dctUniqueTickers.Keys
ThisWorkbook.Worksheets("OutputSheet").Range("A2").Offset(lngDctCounter, 0).Value = CStr(arrTickerOutput)
lngDctCounter = lngDctCounter + 1
Next
End If
By using arrays it's lightning-fast and the extra check for empty cells only improves performance.
Was searching for a while, but cannot find a proper answer. I working on a variant and I used a solution provided below:
http://www.mrexcel.com/forum/excel-questions/305870-eliminate-duplicated-visual-basic-applications-array.html
So what I have is basically a variant which then beeing redimed without duplicates. It works fine if you use just one column from sheet so the variant variable has only 1 column as well.
The data I'm working on needs to be checked for 2 columns, while in the for each loop I would like to refer only to 2nd column:
Dim mgNames As Variant
Range(Cells(1, "I"), Cells(Range("a1").End(xlDown).Row, "J")).Select
mgNames = Selection
Dim myCollection As New Collection
Dim temp As Variant
On Error Resume Next
For Each temp In mgNames
myCollection.Add Item:=temp, Key:=temp
Next temp
On Error GoTo 0
ReDim mgNames(1 To myCollection.Count)
For temp = 1 To myCollection.Count
mgNames(temp) = myCollection(temp)
Next temp
so in part For Each temp In mgNames code takes each value in variant, ex mgnames(1,1) then mgnames(1,2) and so on. I would like to iterate this only for 2nd column, so from (1,2) (2,2), (3,2)...
If anyone is able to help with this it would be great
You don't have to loop through the array with For Each, you can use a normal For, as in
Dim i As Long
...
For i = LBound(mgNames,1) To Ubound(mgNames,1)
myCollection.Add Item:=mgNames(i,2), Key:=mgNames(i,2)
Next i
...