Solved

Expand existing VB code

Posted on 2008-10-01
8
192 Views
Last Modified: 2013-11-25
Hi,

Below is code that practically does what I want.

I now need to expand the Array to include 2 extra dimensions
portfolio which can have up to 750 elements
product which can have up to 25 elements

I have attempted to add the 2 items and the programme bombed out. Increasing the size of the array (to accomodate the increased number of unique combinations), I observed the programme takes a long time to run and eventually bombs out anyway (bad line number of something like that).

nb the source file has currently 12 million records and is growing over time!

Is there a more efficient way of accomodating the extra items without this hit-and-miss approach? Could someone please help.

Thanks


Dim strLine As String
Dim strAcc As String
Dim strBu As String
Dim strNP As String
Dim lngStatus As Long
Dim lngCnt As Long
Dim lngPremium As Long
Dim sPremium As Single
Dim intcounter As Integer
Dim NewArray(1200, 8)
Dim BuArray(10)
Dim blnFound As Boolean
Dim intUniqueItems As Integer: intUniqueItems = 0


Open "c:\movtz.pro" For Input As #1
Open "c:\movtz.txt" For Output As #2
'Open "r:\H\Jun08\tstihz.txt" For Output As #2
'Open "r:\H\Jun08\selih25.pro" For Input As #1

Line Input #1, strLine 'header line


p = 2
Do Until EOF(1)
polval2 = polval1

    Line Input #1, strLine

    strAcc = Mid$(strLine, 33, 1)
    strBu = Mid$(strLine, 3, 2)
    txtstr = Mid$(strLine, 46, 16)
    strNP = Mid$(strLine, 472, 1)
    lngStatus = CLng(Mid$(strLine, 97, 1))
    lngCnt = 1
    lngPremium = CLng(Mid$(strLine, 283, 9))
    sPremium = CLng(Mid$(strLine, 266, 9))

   
    For m = LBound(BuArray, 1) To UBound(BuArray, 1)
    BuArray(m) = strBu
    Next
   
n = 0
Select Case (BuArray(n))
Case (BuArray(n))

    blnFound = False
   
    For intcounter = LBound(NewArray, 1) To UBound(NewArray, 1)
        If NewArray(intcounter, 1) = strAcc And NewArray(intcounter, 2) = strBu And NewArray(intcounter, 3) = txtstr And NewArray(intcounter, 4) = strNP And NewArray(intcounter, 5) = lngStatus Then
            NewArray(intcounter, 6) = CLng(NewArray(intcounter, 6)) + lngPremium
            NewArray(intcounter, 7) = NewArray(intcounter, 7) + sPremium
            NewArray(intcounter, 8) = CLng(NewArray(intcounter, 8)) + 1
            blnFound = True
        End If
    Next
   
    If Not blnFound Then
        intUniqueItems = intUniqueItems + 1
        intAcc = strAcc
        NewArray(intUniqueItems, 1) = strAcc
        NewArray(intUniqueItems, 2) = strBu
        NewArray(intUniqueItems, 3) = txtstr
        NewArray(intUniqueItems, 4) = strNP
        NewArray(intUniqueItems, 5) = lngStatus
        NewArray(intUniqueItems, 6) = lngPremium
        NewArray(intUniqueItems, 7) = sPremium
        NewArray(intUniqueItems, 8) = lngCnt
     End If


End Select
n = n + 1
p = p + 1

Loop


Print #2, "Ind" & "," & "BU" & "," & "Trx_Name" & "," & "NPSale" & "," & "Status" & "," & "Prem" & "," & "SPrem" & "," & "Count"
For intcounter = 1 To 1200
    If NewArray(intcounter, 1) & vbNullString <> vbNullString Then
        Print #2, NewArray(intcounter, 1) & "," & NewArray(intcounter, 2) & "," & NewArray(intcounter, 3) & "," & NewArray(intcounter, 4) & "," & NewArray(intcounter, 5) & "," & NewArray(intcounter, 6) & "," & NewArray(intcounter, 7) & "," & NewArray(intcounter, 8)
    End If
Next intcounter


Close #1
Close #2


MsgBox ("Recs processed: ") + Str(p - 1)
MsgBox ("End of run!")
0
Comment
Question by:hilti
  • 4
  • 4
8 Comments
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 22623666
i think i get what you are trying to do..

why use the select ? (BuArray(n)) is allways the same. = strBu
0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 22623745
try this using a collection to hold indexes.

Sub Test2()
 

   

    Dim strLine As String

    Dim strAcc As String

    Dim strBu As String

    Dim strNP As String

    Dim lngStatus As Long

    Dim lngCnt As Long

    Dim lngPremium As Long

    Dim sPremium As Single

    Dim intcounter As Integer

    ReDim NewArray(3, 100)      'dynamic. reverse order to enable expansion

    Dim BuArray(10)

    Dim blnFound As Boolean

    Dim intUniqueItems As Integer: intUniqueItems = 0

    Dim colFlags As New Collection

    

    Dim ffin As Long, ffout As Long    'get a free file number

    Open "c:\movtz.pro" For Input As #ffin

    'Open "r:\H\Jun08\tstihz.txt" For Output As #2

    'Open "r:\H\Jun08\selih25.pro" For Input As #1

    

        Line Input #ffin, strLine 'header line

    

    

        p = 2

        

        intUniqueItems = 1

        Do Until EOF(ffin)

                 'polval2 = polval1

            p = p + 1

            Line Input #1, strLine

        

            strAcc = Mid$(strLine, 33, 1)

            strBu = Mid$(strLine, 3, 2)

            txtstr = Mid$(strLine, 46, 16)

            strNP = Mid$(strLine, 472, 1)

            lngStatus = CLng(Mid$(strLine, 97, 1))

            strStatus = Mid$(strLine, 97, 1)

            lngCnt = 1

            lngPremium = CLng(Mid$(strLine, 283, 9))

            sPremium = CLng(Mid$(strLine, 266, 9))

        

            'create a unique flag of string indexs

            strflag = strAcc & strBu & txtstr & strNP & strStatus

            

            On Error Resume Next

            colFlags.Add intUniqueItems, strflag

            If Err Then

                'tried to add duplicate so now get index

                intcounter = colFlags.Item(strflag)

             Else

                'success so update current item

                intcounter = intUniqueItems

                intUniqueItems = intUniqueItems + 1

            End If

            If intcouter > UBound(NewArray, 1) Then

                'need to expand array

                ReDim Preserve NewArray(3, intcounter + 50)

            End If

            NewArray(1, intcounter) = CLng(NewArray(1, intcounter)) + lngPremium

            NewArray(2, intcounter) = NewArray(2, intcounter) + sPremium

            NewArray(3, intcounter) = CLng(NewArray(3, intcounter)) + 1

            blnFound = True

                 

        Loop

        

        Close ffin

        

    ffout = FreeFile

    Open "c:\movtz.txt" For Output As #ffout

       

        Print #ffout, "Ind" & "," & "BU" & "," & "Trx_Name" & "," & "NPSale" & "," & "Status" & "," & "Prem" & "," & "SPrem" & "," & "Count"

        For Each itemx In colFlags

            intcounter = itemx

            

            strflag = colFlags.Item(itemx)

            'deconstruct the key from key  & strBu & txtstr & strNP & strStatus
 

                Print #ffout, Mid(strflag, 1, 1) & "," & Mid(strflag, 2, 2) & "," & _

                       Mid(strflag, 4, 16) & "," & Mid(strflag, 20, 1) & "," & _

                       Mid(strflag, 21, 1) & "," & _

                       NewArray(1, intcounter) & "," & NewArray(2, intcounter) & "," & NewArray(3, intcounter)
 

        Next

        

    Close #ffout

        

    

    MsgBox ("Recs processed: ") + Str(p - 1)

    MsgBox ("End of run!")
 

End Sub

Open in new window

0
 

Author Comment

by:hilti
ID: 22625631
Hi,
the key deconstruction does not work

strflag = colFlags.Item(itemx) holds a value not the constructed string

Output is
Ind,BU,Trx_Name,NPSale,Status,Prem,SPrem,Count
1,,,,,661,0,10
2,,,,,4293,0,46
3,,,,,746,0,10
4,,,,,0,0,6
5,,,,,641,0,7
6,,,,,0,0,6
7,,,,,0,0,6
8,,,,,0,0,1
9,,,,,43,0,1
1,0,,,,43,0,1
1,1,,,,43,0,1
1,2,,,,0,0,1
1,3,,,,0,5753,1
1,4,,,,0,0,1
1,5,,,,0,0,1
0
 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 22632952
yes.

should be

strflag = colFlags.Key(intCounter)

0
What Should I Do With This Threat Intelligence?

Are you wondering if you actually need threat intelligence? The answer is yes. We explain the basics for creating useful threat intelligence.

 

Author Comment

by:hilti
ID: 22634553
Thanks

I am trying to understand your programme. I have never collections before so I have learnt something new. I undestand that the collection hold the flags which are stored and retrieved using the key property. Using a msgbox I could see how the flags are being read one-by-one, but one thing I have been not been able to figure out is why when the flags are deconstucted it only outputs the last flag it initially read. Somehow it loses the other flags

So it kicks out the required number of aggregate rows and sums up correctly but the flag (unqiue key)is repeated
Ind,BU,Trx_Name,NPSale,Status,Prem,SPrem,Count
1,XL,TRX_CURR     ,N,1,661,0,10
1,XL,TRX_CURR     ,N,1,4293,0,46
1,XL,TRX_CURR     ,N,1,746,0,10
1,XL,TRX_CURR     ,N,1,0,0,6
1,XL,TRX_CURR     ,N,1,641,0,7
1,XL,TRX_CURR     ,N,1,0,0,6
1,XL,TRX_CURR     ,N,1,0,0,6
1,XL,TRX_CURR     ,N,1,0,0,1
1,XL,TRX_CURR     ,N,1,43,0,1
1,XL,TRX_CURR     ,N,1,43,0,1
1,XL,TRX_CURR     ,N,1,43,0,1
1,XL,TRX_CURR     ,N,1,0,0,1
1,XL,TRX_CURR     ,N,1,0,5753,1
1,XL,TRX_CURR     ,N,1,0,0,1
1,XL,TRX_CURR     ,N,1,0,0,1
0
 
LVL 32

Accepted Solution

by:
Robberbaron (robr) earned 500 total points
ID: 22644031
you are correct. i had got the collection mixed with dictionary.  the key cant be returned from a collection item. need to store a variant array that has both index and key.

Sub Test2()

 

   

    Dim strLine As String

    Dim strAcc As String

    Dim strBu As String

    Dim strNP As String

    Dim lngStatus As Long

    Dim lngCnt As Long

    Dim lngPremium As Long

    Dim sPremium As Single

    Dim intcounter As Integer

    ReDim NewArray(3, 100)      'dynamic. reverse order to enable expansion

    

    Dim intUniqueItems As Integer: intUniqueItems = 0

    Dim colFlags As New Collection, vArray As Variant

    

    Dim ffin As Long, ffout As Long    'get a free file number

    ffin = FreeFile

    Open "c:\movtz.pro" For Input As #ffin

    'Open "r:\H\Jun08\selih25.pro" For Input As #ffin

    

        Line Input #ffin, strLine 'header line

    

    

        p = 2

        

        intUniqueItems = 1

        Do Until EOF(ffin)

                 'polval2 = polval1

            p = p + 1

            Line Input #1, strLine

        

            strAcc = Mid$(strLine, 33, 1)

            strBu = Mid$(strLine, 3, 2)

            txtstr = Mid$(strLine, 46, 16)

            strNP = Mid$(strLine, 472, 1)

            lngStatus = CLng(Mid$(strLine, 97, 1))

            strStatus = Mid$(strLine, 97, 1)

            lngCnt = 1

            lngPremium = CLng(Mid$(strLine, 283, 9))

            sPremium = CLng(Mid$(strLine, 266, 9))

        

            'create a unique flag of string indexs

            strflag = strAcc & strBu & txtstr & strNP & strStatus

            

            On Error Resume Next

            colFlags.Add Array(intUniqueItems, strflag), strflag

            If Err Then

                'tried to add duplicate so now get index

                vArray = colFlags.Item(strflag)

                intcounter = vArray(0)

                Err.Clear

                

             Else

                'success so update current item

                intcounter = intUniqueItems

                intUniqueItems = intUniqueItems + 1

            End If

            If intcouter > UBound(NewArray, 1) Then

                'need to expand array

                ReDim Preserve NewArray(3, intcounter + 50)

            End If

            NewArray(1, intcounter) = CLng(NewArray(1, intcounter)) + lngPremium

            NewArray(2, intcounter) = NewArray(2, intcounter) + sPremium

            NewArray(3, intcounter) = CLng(NewArray(3, intcounter)) + 1

            blnFound = True

                 

        Loop

        

        Close ffin

        

    ffout = FreeFile

    Open "c:\movtz.txt" For Output As #ffout

    'Open "r:\H\Jun08\tstihz.txt" For Output As #ffout

       

        Print #ffout, "Ind" & "," & "BU" & "," & "Trx_Name" & "," & "NPSale" & "," & "Status" & "," & "Prem" & "," & "SPrem" & "," & "Count"

        For Each itemx In colFlags

            vArray = itemx

            intcounter = vArray(0)

            

            strflag = vArray(1)

            'deconstruct the key from key  & strBu & txtstr & strNP & strStatus

 

                Print #ffout, Mid(strflag, 1, 1) & "," & Mid(strflag, 2, 2) & "," & _

                       Mid(strflag, 4, 16) & "," & Mid(strflag, 20, 1) & "," & _

                       Mid(strflag, 21, 1) & "," & _

                       NewArray(1, intcounter) & "," & NewArray(2, intcounter) & "," & NewArray(3, intcounter)

 

        Next

        

    Close #ffout

        

    Set colFlags = Nothing    'detach object

    

    MsgBox ("Recs processed: ") & Str(p - 1) & " :: Unique records=" & Str(intUniqueItems), vbOKOnly

    MsgBox ("End of run!")

 

End Sub

Open in new window

0
 

Author Comment

by:hilti
ID: 22669210
Robberbaron I salute you - you are a genius! Thought I 'd test this code on 8 million recs and see it fall over. It handled the file like a breeze and was done within 10mins! Absolutely awesome. I would like to post a separate question to test my understanding of a particular data scenario. My next action - to allocate your well-deserved 500 points.
0
 

Author Closing Comment

by:hilti
ID: 31504242
Sir you are a GENIUS! Well done. This code makes mince meat of large data files. You are worthy of expert status.
0

Featured Post

6 Surprising Benefits of Threat Intelligence

All sorts of threat intelligence is available on the web. Intelligence you can learn from, and use to anticipate and prepare for future attacks.

Join & Write a Comment

There are many ways to remove duplicate entries in an SQL or Access database. Most make you temporarily insert an ID field, make a temp table and copy data back and forth, and/or are slow. Here is an easy way in VB6 using ADO to remove duplicate row…
Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
Get people started with the utilization of class modules. Class modules can be a powerful tool in Microsoft Access. They allow you to create self-contained objects that encapsulate functionality. They can easily hide the complexity of a process from…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…

705 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

20 Experts available now in Live!

Get 1:1 Help Now