I have the below code to populate a listbox, therefore I want to remove duplicates from my combobox. I Don't know how to do it:
Private Sub CommandButton1_Click()
Dim ws_suivi As Worksheet
Set ws_suivi = ActiveWorkbook.Worksheets("suivi")
Fin_Liste_suivi = ws_suivi.Range("A65530").End(xlUp).Row
For i = 2 To Fin_Liste_suivi
UserForm_SDE.ComboBox_Type_Rapp.AddItem ws_suivi.Range("AD" & i)
Next
UserForm_SDE.Show
End Sub
It is often worth searching to see if a Library for VBA exists that will save you reinventing the wheel.
It is a particular annoyance of VBA that whilst we have such useful structures as Collections and Scripting.Dictionaries there is no easy way to get information into such objects or to do much processing of the data once those objects are populated.
I had a project which had a lot of processing of arrays/scripting.dictionariews and to make my life a little easier I created a VBA library in C# called Kvp (for Key Value Pairs) which is a bit like a Scripting.Dictionary on steriods.
You can download the library, source code, documentation for the Kvp object from here
Once you have added a reference to the Kvp library you can declare a Kvp object in the standard way.
Dim myKvp as Kvp
Set myKvp=New Kvp
You can then add a 1D range from an excel spreadsheet in a single statement
myKvp.AddByIndexFromArray <excel range>.Value
which gives a Kvp of long integers vs cell values
The OP wishes a list of unique values. To do this with a Kvp we can use the Mirror method to create a Kvp of the unique values.
Dim myMirroredKvp as Kvp
set myMirroredKvp=myKvp.Mirror
The Mirror method returns a Two item Kvp where item 0 is a Kvp of unique items vs the first Key at which the item was found and item 1 is a Kvp of original Keys vs value where the values are a duplicate.
You can then get an array of the keys using the GetKeys method
Dim myUniqueValues as Variant
myUniqueValues = myMirroredKvp.GetItem(0).GetKeys
Or should you want the items sorted in reverse order
myUniqueValues - myMirroredKvp.GetItem(0).GetKeysDescending
The above can be shortened to
myUniqueValues = myKvp.Mirror.GetItem(0).GetKeysDescending
I've found the Kvp library quite useful. I hope you do to!!
While you could load the list to a Dictionary, you might find it simpler to try using WorksheetFunction.CountIf to check if the item is further up your list (and has, thus, already been included):
If (i=2) OR (WorksheetFunction.CountIf(ws_suivi.Range(ws_suivi.Cells(2,30),ws_suivi.Cells(i-1,30)), ws_suivi.cells(i,30).Value)<1) Then
UserForm_SDE.ComboBox_Type_Rapp.AddItem ws_suivi.Range("AD" & i)
End If
As a side-note: Since Excel 2007 increased the Row Limit from 65536 (216) to 1048576 (220), you may want to change Fin_Liste_suivi = ws_suivi.Range("A65530").End(xlUp).Row to Fin_Liste_suivi = ws_suivi.Cells(ws_suivi.Rows.Count, 1).End(xlUp).Row
I found :
Dim Valeur As String
Dim i As Integer
Dim j As Integer
'For each element in the list
For i = 0 To lst_ref.ListCount - 1
Valeur = Combobox.List(i)
For j = i + 1 To Combobox.ListCount - 1
'If the element exist, delete it
If Valeur = Combobox.List(j) Then
Call Combobox.RemoveItem(j)
End If
Next j
Next i
It take the beggining of the combobox and check if the value is red again in to the end of the combobox.
Related
I have a 2-dimensional array of values looking like that:
In a different table, I have long strings with VALUE_1, VALUE_2 that can be found anywhere. It looks like in the table below:
Now, I want to write a program that translates the existing VALUE_1, VALUE_2 etc. in the long strings by adding the respective element in the 2nd dimension of the array (/BB, /CCC etc.) and if necessary duplicating and separating the values with a comma and a blank space. So VALUE_1 for example is turned into VALUE_1/BB, VALUE_1/A for each finding in the string. The result is supposed to look exactly like in the table below.
That's challenging. I my first approach I tried to locate the VALUE_1, VALUE_2 in the strings by using InStr() but I don't think that this will help me since only the first hit is taken into consideration. I need every occurrence.
For i = 1 To Worksheets("table2").Range("H1").End(xlDown).Row
For j = LBound(arr2) To UBound(arr2)
If InStr(Worksheets("table2").Range("H" & i), arr2(j, 0)) > 0 Then
Worksheets("table2").Range("H" & i).Font.Bold = True
End If
Next j
Next i
Use your 2D table to build a scripting dictionary so that value1 is associated with the concatenation of all column values in column 2 that have value 1 in the first column.
In the (untested) code below the array (ipArray)is that derived from the 2D range.
Public Function GetReplacements(ByVal ipArray As Variant) As Scripting.dictionary
Dim myD As Scripting.dictionary
Set myD = New Scripting.dictionary
Dim myIndex As Long
For myIndex = LBound(ipArray) To UBound(ipArray)
Dim myKey As String
myKey = ipArray(myIndex, 1)
Dim myItem As String
myItem = ipArray(myIndex, 2)
If myD.exists(myKey) Then
myD.Item(myKey) = myD.Item(myKey) & ", " & myKey & myItem
Else
myD.Add myKey, myKey & myItem
End If
Next
Set GetReplacements = myD
End Function
Now when you find an item such as "Value 1" you can replace with the value retrieved from the dictionary.
Building on #freeflow's excellent answer, I would also use a Scripting.Dictionary to hold the mappings from VALUE1 etc. to the target text.
I would then use Replace for each key in the Dictionary. You can loop like:
Dim key as Variant
For Each key in dict
Replace(<your string>, CStr(key), dict(key))
Next key
This will work so long as all your 'find' strings are totally unique i.e. none of them appears within another - so if you had "Value" and "Value 1" it would not work. Also, the simplest form of this method only works if there is a one-to-one mapping of text strings.
Thus, if your sample data is representative, you would want to look into using the Count argument of Replace so that you can replace the second occurrence of VALUE_4 with the different text, and so on.
I would do this by storing the dict values as an array e.g.
Dim my_arr(1 to 3) as String
my_arr(1) = "VALUE_4/CCC"
my_arr(2) = "VALUE_4/DDDD"
my_arr(3) = "VALUE_4/A"
dict.Add "VALUE_4", my_arr
Then when you are looping through, you can keep track of a counter (call it 'i' for example) and then you can just use Replace with a count of 1, increment 'i' by 1, and then use 'i' in each iteration to call on the relevant element of the array stored against VALUE_4 in the dict, like:
For Each key in dict
For i = LBound(dict(key)) to UBound(dict(key))
Replace (<your string>, CStr(key), dict(key)(i), 1, 1)
Next i
Next key
Hopefully you can build from there to what you need? Having reread your original post, I actually think my simplest solution would work (but I'll leave the more complex solution there in case it's of use to you or others), so long as dict is used to store the one-to-one mapping of, for example, "VALUE_1" to "VALUE_1/BB, VALUE_1/A" - you can loop through your original table and build those strings by concatenation - maybe even directly in the dict:
For Each cell in TableCol1 ' assuming it is cells, otherwise use an appropriate form of loop
tmp_str = cell.Value2
If dict.Exists(tmp_str) Then
dict(tmp_str) = dict(tmp_str) + ", " + tmp_str+cell.Offset(0,1).Value2
Else
dict.Add tmp_str, tmp_str + cell.Offset(0,1).Value2
End If
Next cell
I have a question, in vb.net, how do I go through two lists with a for each or another method?
for example i have defined 3 list
Public NSPS As New List(Of String)
Public CONTENEDOR As New List(Of String)
Public IDCONTENEDOR As New List(Of String)
I have 2 excel files with the same variable CONTENEDOR, and in the other its called IDCONTENEDOR
So i need to create a third excel file that finds the rows with the same IDcontenedor and it adds the variable NSPS as appropriate, to that row in the new excel .
What is the correct way to go through 2 lists with 2 cycles in vb.net
to just fill information in a new excel i use this code
Dim aux As Integer = 1
While (aux <= CONTENEDOR.Count)
hoja1.Cells("B" & aux + 1).Value = NPLANILLA.Item(aux - 1)
aux += 1
End While
aux = 1
Thanks in advance!
I am not sure if I understand your problem. The following answer is based on the best guess I could make.
To find a value corresponding to a key or id, use a dictionary. Dictionaries are much faster than loops for lookups.
Dim dict As new Dictionary(Of String, String)
Assuming that the 2 variables CONTENEDOR and IDCONTENEDOR have the same length and that the first list contains the values corresponding to the ids at the same index, you can fill the dictionary with
For i As Integer = 0 To CONTENEDOR.Count - 1
dict.Add(IDCONTENEDOR(i), CONTENEDOR(i))
Next
Now given an id of type String, you can get the value with
Dim value As String
If dict.TryGetValue(id, value) Then
NSPS.Add(value)
Else
' We did not find a value with this id.
End If
I am not sure where you get the id from, maybe from NPLANILLA.Item(aux - 1)? If it is typed as Object then convert it to String:
Dim id As String
id = CType(NPLANILLA.Item(aux - 1), String)
I am coding a Manager in Excel-VBA with several buttons.
One of them is to generate a tab using another Excel file (let me call it T) as input.
Some properties of T:
~90MB size
~350K lines
Contains sales data of the last 14 months (unordered).
Relevant columns:
year/month
total-money
seller-name
family-product
client-name
There is not id columns (like: cod-client, cod-vendor, etc.)
Main relation:
Sellers sells many Products to many Clients
I am generating a new Excel tab with data from T of the last year/month grouped by Seller.
Important notes:
T is the only available input/source.
If two or more Sellers sells the same Product to the same Client, the total-money should be counted to all of those Sellers.
This is enough, now you know what I have already coded.
My code works, but, it takes about 4 minutes of runtime.
I have already coded some other buttons using smaller sources (not greater than 2MB) which runs in 5 seconds.
Considering T size, 4 minutes runtime could be acceptable.
But I'm not proud of it, at least not yet.
My code is mainly based on Scripting.Dictionary to map data from T, and then I use for each key in obj ... next key to set the grouped data to the new created tab.
I'm not sure, but here are my thoughts:
If N is the total keys in a Scripting.Dictionary, and I need to check for obj.Exists(str) before aggregating total-money. It will run N string compares to return false.
Similarly it will run maximun N string compares when I do Set seller = obj(seller_name).
I want to be wrong with my thoughts. But if I'm not wrong, my next step (and last hope) to reduce the runtime of this function is to code my own class object with Tries.
I will only start coding tomorrow, what I want is just some confirmation if I am in the right way, or some advices if I am in the wrong way of doing it.
Do you have any suggestions? Thanks in advance.
Memory Limit Exceeded
In short:
The main problem was because I used a dynamic programming approach of storing information (preprocessing) to make the execution time faster.
My code now runs in ~ 13 seconds.
There are things we learn the hard way. But I'm glad I found the answer.
Using the Task Manager I was able to see my code reaching 100% memory usage.
The DP approach I mentioned above using Scripting.Dictionary reached 100% really faster.
The DP approach I mentioned above using my own cls_trie implementation also reached 100%, but later than the first.
This explains the ~4-5 min compared to ~2-3 min total runtime of above attempts.
In the Task Manager I could also see that the CPU usage never hited 2%.
Solution was simple, I had to balance CPU and Memory usages.
I changed some DP approaches to simple for-loops with if-conditions.
The CPU usage now hits ~15%.
The Memory usage now hits ~65%.
I know this is relative to the CPU and Memory capacity of each machine. But in the client machine it is also running in no more than 15 seconds now.
I created one GitHub repository with my cls_trie implementation and added one excel file with an example usage.
I'm new to the excel-vba world (4 months working with it right now). There might probably have some ways to improve my cls_trie implementation, I'm openned to suggestions:
Option Explicit
Public Keys As Collection
Public Children As Variant
Public IsLeaf As Boolean
Public tObject As Variant
Public tValue As Variant
Public Sub Init()
Set Keys = New Collection
ReDim Children(0 To 255) As cls_trie
IsLeaf = False
Set tObject = Nothing
tValue = 0
End Sub
Public Function GetNodeAt(index As Integer) As cls_trie
Set GetNodeAt = Children(index)
End Function
Public Sub CreateNodeAt(index As Integer)
Set Children(index) = New cls_trie
Children(index).Init
End Sub
'''
'Following function will retrieve node for a given key,
'creating a entire new branch if necessary
'''
Public Function GetNode(ByRef key As Variant) As cls_trie
Dim node As cls_trie
Dim b() As Byte
Dim i As Integer
Dim pos As Integer
b = CStr(key)
Set node = Me
For i = 0 To UBound(b) Step 2
pos = b(i) Mod 256
If (node.GetNodeAt(pos) Is Nothing) Then
node.CreateNodeAt pos
End If
Set node = node.GetNodeAt(pos)
Next
If (node.IsLeaf) Then
'already existed
Else
node.IsLeaf = True
Keys.Add key
End If
Set GetNode = node
End Function
'''
'Following function will get the value for a given key
'Creating the key if necessary
'''
Public Function GetValue(ByRef key As Variant) As Variant
Dim node As cls_trie
Set node = GetNode(key)
GetValue = node.tValue
End Function
'''
'Following sub will set a value to a given key
'Creating the key if necessary
'''
Public Sub SetValue(ByRef key As Variant, value As Variant)
Dim node As cls_trie
Set node = GetNode(key)
node.tValue = value
End Sub
'''
'Following sub will sum up a value for a given key
'Creating the key if necessary
'''
Public Sub SumValue(ByRef key As Variant, value As Variant)
Dim node As cls_trie
Set node = GetNode(key)
node.tValue = node.tValue + value
End Sub
'''
'Following function will validate if given key exists
'''
Public Function Exists(ByRef key As Variant) As Boolean
Dim node As cls_trie
Dim b() As Byte
Dim i As Integer
b = CStr(key)
Set node = Me
For i = 0 To UBound(b) Step 2
Set node = node.GetNodeAt(b(i) Mod 256)
If (node Is Nothing) Then
Exists = False
Exit Function
End If
Next
Exists = node.IsLeaf
End Function
'''
'Following function will get another Trie from given key
'Creating both key and trie if necessary
'''
Public Function GetTrie(ByRef key As Variant) As cls_trie
Dim node As cls_trie
Set node = GetNode(key)
If (node.tObject Is Nothing) Then
Set node.tObject = New cls_trie
node.tObject.Init
End If
Set GetTrie = node.tObject
End Function
You can see in the above code:
I hadn't implemented any delete method because I didn't need it till now. But it would be easy to implement.
I limited myself to 256 children because in this project the text I'm working on is basically lowercase and uppercase [a-z] letters and numbers, and the probability that two text get mapped to the same branch node tends zero.
as a great coder said, everyone likes his own code even if other's code is too beautiful to be disliked [1]
My conclusion
I will probably never more use Scripting.Dictionary, even if it is proven that somehow it could be better than my cls_trie implementation.
Thank you all for the help.
I'm convinced that you've already found the right solution because there wasn't any update for last two years.
Anyhow, I want to mention (maybe it will help someone else) that your bottleneck isn't the Dictionary or Binary Tree. Even with millions of rows the processing in memory is blazingly fast if you have sufficient amount of RAM.
The botlleneck is usually the reading of data from worksheet and writing it back to the worksheet. Here the arrays come very userfull.
Just read the data from worksheet into the Variant Array.
You don't have to work with that array right away. If it is more comfortable for you to work with dictionary, just transfer all the data from array into dictionary and work with it. Since this process is entirely made in memory, don't worry about the performance penalisation.
When you are finished with data processing in dictionary, put all data from dictionary back to the array and write that array into a new worksheet at one shot.
Worksheets("New Sheet").Range("A1").Value = MyArray
I'm pretty sure it will take only few seconds
After creating a new dictionary:
Dim teams as Dictionary
Set teams = New Dictionary
I noticed that it already contains empty key - value pair (teams.Count returns value of 1).
How can I prevent this from happening or delete this pair? Is this normal behaviour?
I had the same experience and solved it.
I had a Watch expression set for a value in the dictionary. Somehow this kept the empty key/value pair in the dictionary (or kept readding it).
Removing the watch(es) and stepping through the code I now see the dictionary does not have the Empty/Empty item any longer.
If you are referencing the same Microsoft Scripting Runtime dictionary scrrun.dll as me - Excel 2010.
Then the below code returns 0 as the .Count of items after creation with no manipulation.
Sub SD()
Dim teams As Dictionary
Set teams = New Dictionary
Debug.Print teams.Count
End Sub
I wouldn't know the reason why your dictionary returns 1, however I think a workaround it would be to simply use the .RemoveAll method of the Dictionary object
Sub SD()
Dim teams As Dictionary
Set teams = New Dictionary
teams.RemoveAll
Debug.Print teams.Count
End Sub
I am accessing a document from a view, read a datetime field, figure out number of days between two date/time values which fall into four categories. In each category there is a for loop which add number of datetime values to an array of variant. Array entries are between seven and 35. After the loop I like to assign the array values to a date time field on the form and save the document. I have used Notes item as follow:
Dim nitem as Notesitem
Set nitem = doc.ReplaceItemValue("Datefield", dtArray)
It didn't work. I used doc.ReplaceItemValue "Datefield, dtArray this one didn't work either. The field is blank after the agent runs. I declared a variable and assigned the array to the variable then assigned variable to the field on the form:
Dim var1 as variant
var1 = dtArray
doc.datefield = Var1
Still no luck to see array values assigned to the field in the document
Here is main loop
Redim dateArray(0)
For i=0 to NumberofDays -1
set notesitem = dtitem.DateTimeValue
call notesitem.AdjustDay(i)
set dateArray(i) = notesitem
Redim preserve dateArray(i+1)
Next
doc.replaceitemvalue "Datefield", dateArray
call doc.save(false, true)
erase dateArray
Why after the agent runs datefield in the documents are blank? What is missing? How should I change this to get result. Is it possible to add a delemiter to the assignment statement as follows:
Thank you
When you're playing around with NotesItem and the NotesDateTime classes, I think you will have more joy using the NotesItem DateTimeValue property. This is read / write, and returns (or expects) a NotesDateTime object.
For example, if you have a NotesDateTime instance called "dt", this is how you would write it back to a field called "YourDT":
Dim itDT as NotesItem
Dim dt as New NotesDateTime
' Instantiate itDT and dt
...
Set itDT.DateTimeValue = dt
So, you should be able to take your array of NotesDateTime objects, and write it back to the relevant field using this approach.
The simplest way to assign dateTime field from an array is:
SimpleDateFormat smdf = new SimpleDateFormat();
smdf.applyPattern("dd.MM.yyyy");
Vector dates = new Vector();
for (Date dt: dateArray) {
dates.addElement(smdf.formatter(dt));
};
doc.replaceItemValue("dateField", dates);
This is tricky to trouble shoot for you, as you haven't provided the original source code. The way your trying to use methods is a bit strange.
Below is a basic go at what you're trying to do. DateTime fields are a bit tricky, but you can set them using variant arrays.
Dim i As Integer
Dim vDateArr() As Variant
Dim itDate As notesItem
' setup date array.
' .........
' .........
' Now get the date field to be updated from the document
Set itDate = doc.GetFirstItem("fieldName")
' loop through the array of values and make sure they're date time
For i=0 To numberOfDays - 1
' ensure that the array has date type values. V_DATE is a constant defined
' in LSConst.lss. V_DATE = 7, so you can still write the following line as
' If Datatype(vDateArr(i)) <> 7 then
If Datatype(vDateArr(i)) <> V_DATE Then
vDate = Cdat(vDateArr(i))
End If
vDateArr(i) = vDate
Next
' assign the array back onto the itDate field. Even if the field is not
' already a dateTime type. Assigning the array this way will make it so.
itDate.Values = vDateArr
Call doc.Save(True, False)
I find it best to work with primitives, not objects in this case. What's happening here is that I am ensuring that the date values are stored as a dateTime value. Then assigning the array to the field and then saving the document. There are a number of ways to do this, but this is my preferred way when you want to push an array of a specific type into a field. If you can post the original code, it would be easier to correct your code.