Access VBA - How is this code grouping all info for one policy together? - ms-access

So, I inherited some code (below) from someone else and I'm trying to understand how it works. I understand msot of the code (though I'm pretty new to Access VBA) but the one part I don't get is how this code groups all the info for one policy together.
The situation is as follows. To get premium data for a specific policy, from our company database, we have to get it one coverage per line. But, I want all premiums, one for each coverage, all on the same line. So, this code puts it all together from many lines into one line. For simplicity, I knocked it down to 3 total coverages, though there are many more. As I read the code, it seems to assume that all the info for one policy is together, like the 1, 2, or 3 rows for a specific policy are in order. But, even when I, for example, order the table by the premium (amount) column, it still gets all the premium for one policy on one line. I don't see anywhere in the code that should make this work. The code is comparing the policy number on one line to the policy number on the next. If they are the same, group the premium together. If they are different, don't. Again, I could order the table so that the records for one policy are not together, but the end result still comes out right. Am I missing something? Is it something in Access doing it? Thanks for any help!
Option Compare Database
Option Explicit
' Premium is imported with one row for each coverage per policy, so possibly several rows per policy.
' This procedure takes several rows per policy and makes them into one row.
Sub ScrubPremium()
Dim i As Long, j As Long, k As Long
Dim NumRecords As Long, found As Long, UniqueCount As Long
Dim tempPolicyNum As String, tempCoverage As String, tempPremium As Single
Dim PolicyNumArray() As String, PremiumArray() As Single, TotalPremiumArray() As Single
Dim db As DAO.Database
Set db = CurrentDb
Dim infile As Variant, outfile As Variant
Set infile = db.OpenRecordset("Imported Premium")
CurrentDb.Execute "DELETE * FROM [Finalized Premium]"
Set outfile = db.OpenRecordset("Finalized Premium")
NumRecords = infile.RecordCount
ReDim PolicyNumArray(NumRecords)
ReDim PremiumArray(NumRecords, 3)
ReDim TotalPremiumArray(NumRecords)
infile.MoveFirst
'initialize PremiumArray
For i = 1 To NumRecords
For j = 1 To NumPremiums
PremiumArray(i, j) = 0
Next j
Next i
'populate arrays
UniqueCount = 0
For i = 1 To NumRecords
tempPolicyNum = infile![Policy_Number]
tempCoverage = infile![Coverage]
tempPremium = infile![Premium]
k = 0
found = 0
Do Until k = UniqueCount Or found = 1 'check for unique policy
If tempPolicyNum = PolicyNumArray(k + 1) Then
found = 1
Else
k = k + 1
End If
Loop
If found = 0 Then
UniqueCount = UniqueCount + 1
PolicyNumArray(k + 1) = tempPolicyNum
End If
Select Case tempCoverage
Case "Comprehensive"
j = 1
Case "Collision"
j = 2
Case Else
j = 3
End Select
PremiumArray(k + 1, j) = PremiumArray(k + 1, j) + tempPremium
TotalPremiumArray(k + 1) = TotalPremiumArray(k + 1) + tempPremium
infile.MoveNext
Next i
'Populate table
For i = 1 To UniqueCount
outfile.AddNew
outfile![Full Policy Number] = PolicyNumArray(i)
outfile![Comp Premium] = PremiumArray(i, 1)
outfile![Coll Premium] = PremiumArray(i, 2)
outfile![Other Premium] = PremiumArray(i, 3)
outfile![Total Premium] = TotalPremiumArray(i)
outfile.Update
Next i
infile.Close
outfile.Close
End Sub

The code is comparing the policy number on one line to the policy
number on the next. If they are the same, group the premium together.
If they are different, don't.
Almost.
There are two loops here. One walks through each row of your input file. On each row of the input file, a second loop walks through (potentially all of) PolicyNumArray, looking for policy numbers that match the number taken from the input file.
If I were you, I'd step through this with the debugger. Make sure it's doing what you expect it to do. I'd want to look closely at this part (some lines snipped).
UniqueCount = 0
For i = 1 To NumRecords
k = 0
Do Until k = UniqueCount

Related

Access: Increment/Decrement a number with 2 dots

I have two fields for current version number and previous version number in a form. What I want to do is when I enter the current version number (which is written like this 18.04.15), the previous version number on the next text box to automatically fill itself with 18.04.14.
I tried:
=[txtCurrentVersion]-1 in the control source, but obviously because I'm not decrementing by one, it didn't work.
Would appreciate some guidance, thanks :)
Below code splits the text based on dot and subracts one from last item.
Private Sub txtCurrentVersion_AfterUpdate()
If Nz(Me.txtCurrentVersion, "") <> "" Then
Me.txtPrevVersion.Value = Split(Me.txtCurrentVersion, ".")(0) & "." & Split(Me.txtCurrentVersion, ".")(1) & "." & Split(Me.txtCurrentVersion, ".")(2) - 1
End If
End Sub
I would suggest creating a function where you give the function 3 parameters, the 1st is the current version number string, the 2nd is the version number level (0 for major number, 1 for subversion number and 2 for minor version number) and the value to increase or decrease.
for example:
Function ModifyVersion(VersionNumber, NumberLevel, Number)
If VersionNumber <> "" AND NumberLevel >= 0 AND NumberLevel < 3 Then
dim VersionArray
VersionArray = Split(VersionNumber, ".")
Select Case NumberLevel
Case 0
VersionArray(0) = VersionArray(0) + Number
Case 1
VersionArray(1) = VersionArray(1) + Number
Case 2
VersionArray(2) = VersionArray(2) + Number
End Select
ModifyVersion = VersionArray(0) & "." & VersionArray(1) & "." & VersionArray(2)
End If
End Function
Then to decrease one from the minor version number use:
VersionNumber = [txtCurrentVersion]
Dim UpdateVersion
UpdateVersion = ModifyVersion(VersionNumber, 2, -1)

Compare index of 2 elements in a collection

Issue : I have some issues figuring out a way to select elements in my HTMLDocument which are under a certain point in the page.
In the following code sample, as you can see in the comments, I first select a part of them which respect my queryselector criteria
IEDoc.querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']")
In this example I have 10 elements in this collection. Each of this element in contained in a table which is its parent on the 7th degree.
MsgBox TypeName(IEDoc.querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']")(2).ParentNode.ParentNode.ParentNode.ParentNode.ParentNode.ParentNode.ParentNode) ' HTMLTable
Some of those elements are in the same table.
You can see here the form which contains all the tables .
Now, the thing is that I want to select the innerHTML of some of those elements only and not all of them. The criterion to know if I one of those 10 elements interests me or not is it's position on the webpage. I want all the elements which are under the message Part Usage. There is only one table containing the Part Usage text and so my idea was to see if the table in which are contained each element has a higher or lower index in the "form" collection.
If the index is higher I want this element, otherwise I discard it.
What I did for this is the following code :
I set the ID Bim to all the tables containing one or more
from the 10 elements.
For Each Element In IEDoc.querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']") ' here for all of the 10 numbers found with the queryselectorall we'll find their respective table in the collection (form) and set its Class as "Bim". But since some of the numbers are in the same table, we won't have 10 tables with a classname "Bim" at the end of the process. We'll have only x tables with the classname "Bim"
Element.ParentNode.ParentNode.ParentNode.ParentNode.ParentNode.ParentNode.ParentNode.Class = "Bim"
Next
I set the ID Stop to the table containing the text Part Usage
For Each Element In IEDoc.getElementsByClassName("SectionHead")
If Element.innerHTML = "Part Usage" Then
'MsgBox TypeName(Element.ParentNode.ParentNode.ParentNode)' HTMLTable
Element.ParentNode.ParentNode.ParentNode.ID = "Stop"
End If
Next
I check which tables with the Classname Bim are under (=higher index) the table with the ID Stop. For the table ( there is actually only one) matching the criterion of point 3 I apply IEDoc.querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']") inside of them so that I get all the elements in contains and more paricularly their innerHTML.
For Each Element In IEDoc.getElementsByClassName("Bim") ' Here we check all the x tables which have the Classname "Bim"
If Element.indexInTheWholeForm > IEDoc.getElementById("Stop").indexInTheWholeForm Then 'and compare somehow if their index in the (form) collection if higher than the table with the ID "Stop" ( this is similar to checking if the element if lower on the webpage in thic case) ( we only want the element which have a higher index aka under the Part Usage table)
For Each Element2 In Element.querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']") ' Now we are in the table which contains the part numbers and we'll look for all the part numbers it contains by applying the queryselectorall again, but this time only in this specific table
array_parts2(iteration2) = Element.querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']")(iteration2).innerHTML
ActiveWorkbook.Worksheets(1).Cells(iteration2 + 1, 19) = array_parts2(iteration2)
iteration2 = iteration2 + 1
Next
End If
Next
of course what doesn't work is the indexInTheWholeForm property which doesn't exist. Any ideas on how to do this ?
Thank for reaching that line :)
Untested but I would do something like this (assuming I understood you correctly)
Sub Tester()
Const S_MATCH As String = "td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']"
Dim e, tbl, bHit As Boolean
'...
'load page etc
'...
'get all the matching rows and cycle though them
For Each e In IEDoc.querySelectorAll(S_MATCH)
'did we get to the table of interest yet?
If Not bHit Then
Set tbl = e.ParentNode.ParentNode.ParentNode.ParentNode. _
ParentNode.ParentNode.ParentNode
If IsPartUsageTable(tbl) Then bHit = True
End If
If bHit Then
'we reached the table of interest, so
' do something with e
End If
Next
End Sub
Function IsPartUsageTable(tbl) As Boolean
Dim e, rv As Boolean
For Each e In tbl.getElementsByClassName("SectionHead")
If Element.innerHTML = "Part Usage" Then
rv = True
Exit For
End If
Next
IsPartUsageTable = rv
End Function
Ok, so as unexpected as it sounds, I think I found a solution to my own question. I will confirm you that it works as soon as I have the possibility to run it with my colleague.
So I keep point 1 and 2 from my initial post and I replaced point 3 with the following :
For i = 0 To IEDoc.getElementsByTagName("form")(0).getElementsByTagName("table").length
If IEDoc.getElementsByTagName("form")(0).getElementsByTagName("table")(i).ID = "Stop" Then
index_Part_Usage = i
Position_Part_Usage = index + 1
Exit For
End If
Next
'MsgBox Position_Part_Usage
For i = 0 To IEDoc.getElementsByTagName("form")(0).getElementsByTagName("table").length
If IEDoc.getElementsByTagName("form")(0).getElementsByTagName("table")(i).className = "Bim" Then
index = i
Position = index + 1
If index > index_Part_Usage Then
For Each Element2 In IEDoc.getElementsByTagName("form")(0).getElementsByTagName("table")(i).querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']") ' Now we are in the table which contains the part numbers and we'll look for all the part numbers it contains by applying the queryselectorall again, but this time only in this specific table
array_parts2(iteration2) = IEDoc.getElementsByTagName("form")(0).getElementsByTagName("table")(i).querySelectorAll("td[width='100'][class='ListMainCent'][rowSpan='1'][colSpan='1']")(iteration2).innerHTML
ActiveWorkbook.Worksheets(1).Cells(iteration2 + 1, 19) = array_parts2(iteration2)
iteration2 = iteration2 + 1
Next
End If
End If
Next i

VBA MS Word content controls messed order

I have a table with about 15 content controls. The content controls have different titles.
Now, I copy-paste the table with content controls a couple of times, and later, get different values into every single content control from the database. Since the content controls from different tables share the same name, I thought of looping through number of tables using something like this
seqNo = 1
For Each t in MyTables
ActiveDocument.SelectContentControlsByTitle("title1").Item(seqNo).Range.Text = "some value 1 from DB"
ActiveDocument.SelectContentControlsByTitle("title2").Item(seqNo).Range.Text = "some value 2 from DB"
' and so on
seqNo = seqNo + 1
Next
The problem is when I use this code, my content controls don't get filled in sequentially. I mean, for example, content control with title title1 from table1 isn't filled with its value, instead, content control with title title1 from table4 gets that value. And this mess goes around really bad: values from table 2 can end up in table 4, 9, 10 and so forth.
I think the order of content controls gets messed up somehow when I copy-paste the tables.
And clue how to get it right?
Didn't really find why this happens, but went with giving unique names to the content controls, like title1, title2, and so on, and then looping through all of them to set the needed values.
Oh my god yes... I have stumbled upon the same annoying issue too. My workaround has been after the copy change the title in code then paste and change that one too (see below). Now my issue is that this takes WAY too long to run since I'm filling out many of these templates in my code. I'm currently at a lose as how to speed this process up or a different approach I should been using.
objWord.ActiveDocument.Range(start:=objWord.ActiveDocument.Tables(3).Range.Rows(1).Range.start, End:=objWord.ActiveDocument.Tables(3).Range.Rows(5).Range.End).Copy
objWord.Selection.EndKey Unit:=wdStory
objDoc.SelectContentControlsByTitle("Date").Item(1).Title = "Date1"
objDoc.SelectContentControlsByTitle("StartTime").Item(1).Title = "StartTime1"
objDoc.SelectContentControlsByTitle("EndTime").Item(1).Title = "EndTime1"
objDoc.SelectContentControlsByTitle("Mins").Item(1).Title = "Mins1"
objDoc.SelectContentControlsByTitle("Note").Item(1).Title = "Note1"
objDoc.SelectContentControlsByTitle("Grp").Item(1).Title = "Grp1"
objDoc.SelectContentControlsByTitle("acc1").Item(1).Title = "acc1_1"
objDoc.SelectContentControlsByTitle("acc2").Item(1).Title = "acc2_1"
objDoc.SelectContentControlsByTitle("acc3").Item(1).Title = "acc3_1"
objDoc.SelectContentControlsByTitle("acc4").Item(1).Title = "acc4_1"
objDoc.SelectContentControlsByTitle("acc5").Item(1).Title = "acc5_1"
objDoc.SelectContentControlsByTitle("acc6").Item(1).Title = "acc6_1"
objDoc.SelectContentControlsByTitle("acc7").Item(1).Title = "acc7_1"
objDoc.SelectContentControlsByTitle("acc8").Item(1).Title = "acc8_1"
For j = 2 To UBound(Narray)
objWord.Selection.Paste
objDoc.SelectContentControlsByTitle("Date").Item(1).Title = "Date" & j
objDoc.SelectContentControlsByTitle("StartTime").Item(1).Title = "StartTime" & j
objDoc.SelectContentControlsByTitle("EndTime").Item(1).Title = "EndTime" & j
objDoc.SelectContentControlsByTitle("Mins").Item(1).Title = "Mins" & j
objDoc.SelectContentControlsByTitle("Note").Item(1).Title = "Note" & j
objDoc.SelectContentControlsByTitle("Grp").Item(1).Title = "Grp" & j
objDoc.SelectContentControlsByTitle("acc1").Item(1).Title = "acc1_" & j
objDoc.SelectContentControlsByTitle("acc2").Item(1).Title = "acc2_" & j
objDoc.SelectContentControlsByTitle("acc3").Item(1).Title = "acc3_" & j
objDoc.SelectContentControlsByTitle("acc4").Item(1).Title = "acc4_" & j
objDoc.SelectContentControlsByTitle("acc5").Item(1).Title = "acc5_" & j
objDoc.SelectContentControlsByTitle("acc6").Item(1).Title = "acc6_" & j
objDoc.SelectContentControlsByTitle("acc7").Item(1).Title = "acc7_" & j
objDoc.SelectContentControlsByTitle("acc8").Item(1).Title = "acc8_" & j
Next

Using .Find in a Recursive Function

I am trying to find the row number in a sheet using the .Find function in a recursive function.
I set an object called Found = .Find.... and it works great... for a little bit. I set it when I'm 1 level of recursion deep, then set it again when I'm 2 levels deep. Then, my code finds the end of the path and starts backing up until it gets back to 1 level deep, but not my Found object has been re-declared and kept its values from the 2nd level. My other variables (ThisRow etc...) keep the value of the level that they are in, and that's what I would like to do with the object Found. Is there a way that I can declare Found locally so that it's value doesn't extend to the next function, and can't be overwritten in a deeper level? You can find my code below for reference.
Here is my current code - irrelevant parts cut out:
Public Function FindChildren()
ThisRow = AnswerRow 'Also declared before function call
BeenHereCell = Cells(ThisRow, "O").Address
If Range(BeenHereCell).Value = "Yes" Then
Exit Function 'That means we've already been there
End If
Range(BeenHereCell).Value = "Yes"
With Worksheets("MasterScore").Range("j1:j50000")
Set Found = .Find(NextQuestionID, LookIn:=xlValues)
If Not Found Is Nothing Then
firstAddress = Found.Address
NextCell = Found.Address
Do
AnswerRow = Range(NextCell).Row
FindChildren 'This is where it's recursive.
Set Found = .FindNext(Found)
NextCell = Found.Address
Loop While Not Found Is Nothing And Found.Address <> firstAddress
End If
End With
End Function
Now I have gotten around it by activating cells, but it makes my code a lot slower. Currently I am using this:
Set Found = Worksheets("MasterScore").Range("j1:j50000").Find(NextQuestionID, LookIn:=xlValues)
If Not Found Is Nothing Then
Count = 1
Do
Columns("J:J").Select
FirstFoundRow = Selection.Find(What:=NextQuestionID, After:=ActiveCell, LookIn:= _
xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:= _
xlNext, MatchCase:=False, SearchFormat:=False).Row
For i = 1 To Count
Selection.FindNext(After:=ActiveCell).Activate
Next i
AnswerRow = ActiveCell.Row
If AnswerRow = FirstFoundRow And Count <> 1 Then Exit Do
FindChildren
Count = Count + 1
Loop
End If
This way, I don't have to set the value of the object again, but I have to iterate through it.FindNext quite a few times and each time it runs that line its also activating the row. I really just want something like.
AnswerRow = .Find(nth instance of NextQuestionID).Row
(I have about 50k rows and the count goes to about 20 pretty often so it really takes a while).
I'd appreciate any ideas! Currently my code is working, but it's going to take a good part of the day to complete, and I'll need to run this again at some point!
I ended up finding a way to speed it up a little bit. I think this could help someone so I will share what I've found.
It's not the best solution (I would have preferred to just declare the object locally so my other functions wouldn't change it's value), but at least with this I'm not looping through 20 or so finds every iteration of the Do Loop.
Set Found = Worksheets("MasterScore").Range("j1:j50000").Find(NextQuestionID, LookIn:=xlValues)
If Not Found Is Nothing Then
NextAnswerRange = "j" & 1 & ":" & "j50000" 'The first search will be from the beginning
Do
Set Found = Worksheets("MasterScore").Range(NextAnswerRange).Find(NextQuestionID, LookIn:=xlValues)
NextCell = Found.Address
AnswerRow = Range(NextCell).Row
NextAnswerRange = "j" & AnswerRow & ":" & "j50000"
If LastAnswerRange = NextAnswerRange Then Exit Function 'This would mean we've reached the end.
LastAnswerRange = NextAnswerRange
FindChildren
Loop
End If
End Function
So we know we've already covered our bases with previous ranges since it always finds the immediate next. We just change the range of the search each time and it will find the next value.
A weird thing about this solution is that if you are looking for a value among range 70 -> 50,000 and you have the answer your looking for on row 70, it will actually find the next row (it skips that first one). But, if there aren't any rows past 70 that have the answer, it will actually take the value from row 70. That meant that I couldn't do
NextAnswerRange = "j" & AnswerRow + 1 & ":" & "j50000"
because it would miss some values. Doing it without the + 1 meant at the end of the document I would end up searching the same last value over and over (it would never go back to Found Is Nothing) so I had to put in the check to see if the LastAnswerRange = NextAnswerRange.
I hope this helps someone. I don't think it's the most elegant solution, but it's a lot faster than what I had.

How can I determine the query execution time in ms access 2007?

I'd like to determine the effect that changes to my queries are having. To do this, I need some performance metric. Is it possible to determine the execution time for a query in MS Access? Using external programs, or changing the registry (SHOWJETPLAN) are not an option as my workstation is really locked down by the network admins... so I need an in-Access solution. Thanks!
I have a quick and dirty approach that I use for evaluating relative performance of alternative algorithms, be they different functions, queries, etc.
I make use of the Run command of the Access.Application object. It allows me to quickly compare 2, 3, 4, etc., different approaches. For each additional approach, I just create another Function named ThingX.
I then use the number of iterations to work around GetTickCount's limitation of roughly 10 ms accuracy. If you want even finer resolution than GetTickCount can provide, you can use a high-resolution timer like QueryPerformanceCounter. Personally, I don't think that is worth all the extra work. If you are writing performance critical code in VBA and are worried about shaving microseconds off your execution time, you're using the wrong tool (VBA) for the job.
Private Declare Function GetTickCount Lib "kernel32" () As Long
Sub TimeThings() 'vv
Const NumThings = 2
Const Iterations = 2500
Dim t As Integer, i As Integer, s As Long
For t = 1 To NumThings
s = GetTickCount
For i = 1 To Iterations
'Debug.Print Run("Thing" & t, i)
Run "Thing" & t, i
Next i
Debug.Print "Thing "; t, GetTickCount - s; " ms elapsed"
Next t
End Sub
Function Thing1(Optional Val)
Dim i
For i = 1 To Val
Thing1 = Thing1 & Chr(65 + (i Mod 57))
Next i
End Function
Function Thing2(Optional Val)
Dim i
Thing2 = Space(Val)
For i = 1 To Val
Mid(Thing2, i) = Chr(65 + (i Mod 57))
Next i
End Function
On my system, running TimeThings() yields the following output:
Thing 1 4087 ms elapsed
Thing 2 2652 ms elapsed