Solved

Expand existing VB code

Posted on 2008-10-01
8
200 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
Creating Instructional Tutorials  

For Any Use & On Any Platform

Contextual Guidance at the moment of need helps your employees/users adopt software o& achieve even the most complex tasks instantly. Boost knowledge retention, software adoption & employee engagement with easy solution.

 
LVL 32

Expert Comment

by:Robberbaron (robr)
ID: 22632952
yes.

should be

strflag = colFlags.Key(intCounter)

0
 

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

Free Tool: Path Explorer

An intuitive utility to help find the CSS path to UI elements on a webpage. These paths are used frequently in a variety of front-end development and QA automation tasks.

One of a set of tools we're offering as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Suggested Solutions

Title # Comments Views Activity
Access query that references subform 5 48
How does CurrentUser work? 10 42
MS SQL store procedure to calculate and return result 6 69
Child Form in front 4 58
Introduction While answering a recent question (http://www.experts-exchange.com/Q_27402310.html) in the VB classic zone, I wrote some VB code in the (Office) VBA environment, rather than fire up my older PC.  I didn't post completely correct code o…
The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
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…

697 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