I have tried to find leads with the Microsoft project VBA but I was not successful I tried the following code but it gives me 2280 leads while the total number of relations in my schedule is 2156
Sub NumberofLeads()
Dim Lead As Integer
Dim t As Task
Dim td As TaskDependency
Lead = 0
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then
For Each td In t.TaskDependencies 'looping in all the relations of a task
If td.Lag < 0 Then
Lead = Lead + 1
End If
Next
End If
Next t
MsgBox Lead & " Leads exist."
End Sub
Each task dependency consists of two tasks so looping through the tasks and then through all of each task's dependencies will encounter each dependency twice. The best way to handle this is to only look at the dependencies where the task is the predecessor (or successor, just pick one), by checking the From (or To) object's Unique ID and compare it to the current task:
Sub NumberofLeads()
Dim Lead As Integer
Dim t As Task
Dim td As TaskDependency
Lead = 0
For Each t In ActiveProject.Tasks
If Not t Is Nothing Then
For Each td In t.TaskDependencies
If td.From.UniqueID = t.UniqueID And td.Lag < 0 Then
Lead = Lead + 1
End If
Next
End If
Next t
MsgBox Lead & " Leads exist."
End Sub
Note: In case dividing by two seems easier than this solution, consider the case of external links. In that case the dependency will only be encountered once (the second task is not in the ActiveProject.Tasks collection) so dividing by two would yield the wrong answer.
Related
This is my first question. I can't solve this error for 2 weeks.
In order to solve the problem signed up.
This is my vb code.
Try
For i As Integer = 0 To ListBox1.Items.Count - 1 Step 1
For j As Integer = 0 To ListBox2.Items.Count - 1 Step 1
If ListBox1.Items(i).ToString().Equals(ListBox2.Items(j).ToString()) = True Then
ListBox1.Items.RemoveAt(i)
End If
Next
Next
Catch ex As Exception
MsgBox("LOAD ERROR: " + ex.Message, vbCritical, "ERROR")
End Try
error :
InvalidArgument=Value of '20' is not valid for 'index'(' ' is varient.)
Project has no problems except for this error
Try this:
Dim items = ListBox1.Items.Where(Function(item) ListBox2.Items.Contains(item)).ToList()
For Each item in items
ListBox1.Remove(item)
Next
When I run your code, I receive a different exception, argument out of range...and that is caused by deleting items from an indexed collection while you're iterating through it. For example, let's say listbox1 has 10 items in it. If you find item number 1 in listbox2 and delete it, now you only have 9 items left in listbox1. The problem is, when you entered your loop, you told it to loop 10 items, and it will still try to do that. At some point, if any items are deleted, this loop will throw an exception...so you will need to change that sooner or later. To mitigate this, step through the collection that you'll be deleting items from backward like this:
For i As Integer = ListBox1.Items.Count - 1 to 0 Step -1
When I run the code with the change shown above, it works as intended and removes the duplicate items from listbox1. Unfortunately, I was unable to reproduce your invalid argument exception. It's odd to see that because usually that exception likes to pop up when using listviews, not listboxes. Perhaps you can edit your post and add a screenshot of the data in your listboxes so it's easier for other people to troubleshoot.
As you remove items from ListBox1 the total item count will decrease (obviously), however the For loop does not respect that. A For loop will only have the right side of To set once, which is done prior to the first iteration.
What you're currently doing is actually equal to this:
Dim a As Integer = ListBox1.Items.Count - 1
For i As Integer = 0 To a Step 1
Dim b As Integer = ListBox2.Items.Count - 1
For j As Integer = 0 To b Step 1
...
Next
Next
The fix for this is simple; create a variable that holds how many items you have removed, then, in an If-statement, check if i is more or equal to the current item count subtracted with how many item's you've removed. If so, exit the loop.
Dim ItemsRemoved As Integer = 0
For i As Integer = 0 To ListBox1.Items.Count - 1 Step 1
If i >= ListBox1.Items.Count - ItemsRemoved Then Exit For
For j As Integer = 0 To ListBox2.Items.Count - 1 Step 1
If ListBox1.Items(i).ToString().Equals(ListBox2.Items(j).ToString()) = True Then
ListBox1.Items.RemoveAt(i)
End If
Next
Next
For future reference you should also always remove/comment out the Try/Catch-statement so you can see where the error occurs and get more detail about it.
The point of my answer is that when you iterating any collection, you should NOT try to modify this collection. In for-loops you run into such trouble. But you can iterate using while-loop with no issues
Try
Dim index As Integer = 0
While index < ListBox1.Items.Count '!! this code based on fact that ListBox1 item Count changes
For j As Integer = 0 To ListBox2.Items.Count - 1 ' <- this is ok because ListBox2 doesn't chage
If string.Equals(ListBox1.Items(index).ToString(), ListBox2.Items(j).ToString()) Then
ListBox1.Items.RemoveAt(index)
Continue While ' no index increase here because if you remove item N, next item become item N
End If
Next
index += 1
End While
Catch ex As Exception
MsgBox("LOAD ERROR: " + ex.Message, vbCritical, "ERROR")
End Try
This is good example of how things actually work. And it shows few techniques
I just selected Build-->Clean solution and it cleaned out the bad elements. This occurred as a result of adding and deleting menu items, without deleting the subroutines of the deleted menu items. As soon as I cleaned the solution, and then ran the project, the error was gone.
Within MS Project I'm handling different levels of tasks and subtasks.
As I have a long list I would be able to setup a personalized Unique ID for each one of them based on their parent taks and grandparent task.
My outline levels are:
Lot (LO)
Phase (PH)
Category (CA)
Chapter (CH)
Deliverable (DE)
Task (TA)
At the end, I would like to have a reference in each line such as:
LO1.PH01.CA01.CH01.DE01.TA01 (for the first task in the first Deliverable in the first Chapter .... and so on
The second task in the same deliverable should be: LO1.PH01.CA1.CH1.DE1.TA2
The line of the parent level (Deliverable)should look lie: LO1.PH01.CA01.CH01.DE01.TAOO as some deliverables have no tasks assigned yet.
Would there be an automated way (VBA code or custom field function) to determine that reference and also to check that it is indeed unique?
Thanks a lot in advance for any help on this!
Regards,
Fabien
PS: The outline levels provided by MSP are not always aligned between each "Lot" as in some "Lot" I don't have the "Category CA" level. In other words, the deliverable is not always on outline level 5.
You need a recursive function which accepts a Task object and a string identifier. Given that you do not want to update the name property of the task, I would use the Notes property to store the identifier.
Option Explicit
Public Sub RecurseStart()
Dim taskeach As Task
Dim lngcount As Long
For Each taskeach In ThisProject.Tasks
lngcount = lngcount + 1
If taskeach.OutlineLevel = 1 Then
TaskID taskeach, Right(taskeach.Name, 2) & lngcount
End If
Next taskeach
End Sub
Public Sub TaskID(sometask As Task, someid As String)
Dim subtask As Task
Dim lngcount As Long
Dim someotherid As String
For Each subtask In sometask.OutlineChildren
someotherid = someid & "."
lngcount = lngcount + 1
someotherid = someotherid & Right(subtask.Name, 2) & lngcount
If subtask.OutlineChildren.Count <> 0 Then
TaskID subtask, someotherid
End If
subtask.Notes = someotherid
someotherid = someid
Next
End Sub
I'm back with another question that probably has a simple answer. I really fall down when it comes to loops, so this is what I am trying to build.
I am building a form where user will type in a number between 1 and 156 (named range "GenNo") and click a Generate button.
I need a loop that will copy a template built in the "Template" tab of the spreadsheet with the named range also being "Template", and then insert it into the main form page the specified amount of times. This way the rest of the content and other named ranges should be pushed down accordingly.
Probably a very simple answer but I am terrible when it comes to loops and would not know where to start.
Thanks for your help.
EDIT: This attempt only generates one template in the form:
Sub Generate()
' Check if payslips are already generated
If Sheets("Data").Range("GenLogic").Value = 1 Then
MsgBox ("Already Generated! Please clear the form and regenerate.")
Else
Sheets("Data").Range("GenLogic").Value = 1
End If
' Loop code
Do Until Sheets("Data").Range("LoopLogic").Value = Range("GenNo").Value
Sheets("Template").Range("Template").Copy
Sheets("Overpayment Form").Range("Start").Insert
Range("LoopLogic") = Cell.Value + 1
Loop
End Sub
i would give this a shot; note that i removed your updating of your loop variables. Also, i've rewritten your loop to use a for, and shift down on insert.
Sub Generate()
' Check if payslips are already generated
If Sheets("Data").Range("GenLogic").Value = 1 Then
MsgBox ("Already Generated! Please clear the form and regenerate.")
Else
Sheets("Data").Range("GenLogic").Value = 1
End If
' Loop code
Dim iFrom As Long, iTo As Long, i As Long
iFrom = Sheets("Data").Range("LoopLogic").Value
iTo = Range("GenNo").Value
For i = iFrom To iTo
Sheets("Template").Range("Template").Copy
Sheets("Overpayment Form").Range("Start").Insert Shift:=xlDown
Next
End Sub
As a newbie in VBA (Excel), I am trying to make a tool, which determines what the diagnostic yield of a certain test must be; in order to be cost-effective as a pre-screening to another diagnostic test.
What I want it to do is calculate for a certain yield of test A, at what yield for test B the costs per diagnosis are the same for both tests. The code I wrote has to loop for a certain range for the diagnostic yield and exit this loop when the costs per diagnosis for test A drop under the costs per diagnosis for test B.
However, the code keeps looping for this range, but does not stop when my condition on costs is met. I tried a lot, including do while and do until statements, but it just won't work. I really hope someone could help me out! Many thanks in advance! Kirsten
Sub TGP_WES_OR_WES()
Dim Yield_A As Double
Dim Yield_B As Double
Dim Yield_A_max As Double
Dim Cost_diagnosis_A As Double
Dim Cost_diagnosis_B As Double
Yield_B = Range("C6")
Yield_A_Max = Yield_B - 0.1
Cost_diagnosis_B = Range("E15")
Cost_diagnosis_A = Range("E11")
Do While Yield_A < Yield_A_max
For Yield_A = 1 To Yield_A_max Step 0.1
Range("C5").Value = Yield_A
If Cost_diagnosis_A < Cost_diagnosis_B Then
Exit For
End If
Next Yield_TGP
Loop
Range("D1").Value = Yield_TGP
End Sub
You have a double loop (both of which appear to be doing the same thing):
Do While Yield_A < Yield_A_max
For Yield_A = 1 To Yield_A_max Step 0.1
...
Next Yield_TGP
Loop
Remove the outer do loop for starters.
The 2nd issue I see is that your loop exit conditions do not appear to depend on the loop iteration. That is to say Cost_diagnosis_A and Cost_diagnosis_B are not updated or changed by the loop. This generally indicates a design error as nearly all loop termination conditions will be dependent upon a value the loop is calculating or updating (or overall loop progress). Intuitively, your loop termination condition should incorporate Yield_A either directly or indirectly (from a downstream calculation). Perhaps you want to be updating the values of Cost_diagnosis_A and/or Cost_diagnosis_B inside your loop body, based on Yield_A?
I want to iterate over all rows of a MS-Word mail merge data source and extract the relevant data into an XML.
I'm currently using this code:
Imports Microsoft.Office.Interop
Do
objXW.WriteStartElement("Recipient")
Dim objDataFields As Word.MailMergeDataFields = DataSource.DataFields
For Each FieldIndex As Integer In mdictMergeFields.Keys
strValue = objDataFields.Item(FieldIndex).Value
If Not String.IsNullOrEmpty(strValue) Then
strName = mdictMergeFields(FieldIndex)
objXW.WriteElementString(strName, strValue)
End If
Next
objXW.WriteEndElement()
If DataSource.ActiveRecord = LastRecord Then
Exit Do
Else
DataSource.ActiveRecord = Word.WdMailMergeActiveRecord.wdNextDataSourceRecord
End If
Loop
And it turns out to be a little sluggish (About 1 second for each row). Is there any way to do it faster?
My fantasy is finding a function like MailMergeDataSource.ToDatatable and then inspecting the datatable.
Any time you're iterating through something row by row, and then doing some kind of processing on each row, is going to get a little slow.
I would be inclined to approach this problem by having a step before this which prepared the mdictMergeFields collection so that it only contained elements that were not 'null or empty', this will mean you won't have to check for that on each iteration. You could do this in process, or 'sneakily' in the background while the user is doing something else.
The other thing to try (might help!) is to change the "Do... Loop" block so that you're not checking at the end of each imported row whether or the record is the 'last record'. Instead, get a count of the records, and then compare the current index to the knowm maximum (which might be quicker)
I.E.:
Dim i, x as Integer
i = ActiveDocument.MailMerge.DataSource.RecordCount
Do While x < i
objXW.WriteStartElement("Recipient")
Dim objDataFields As Word.MailMergeDataFields = DataSource.DataFields
For Each FieldIndex As Integer In mdictMergeFields.Keys
strValue = objDataFields.Item(FieldIndex).Value
If Not String.IsNullOrEmpty(strValue) Then
strName = mdictMergeFields(FieldIndex)
objXW.WriteElementString(strName, strValue)
End If
Next
objXW.WriteEndElement()
x += 1
Loop
I don't really work with the Office Interop much, but hopefully this might offer some assistance! Post back, let me know how it goes.
/Richard.