Solved

Expand existing VB code

Posted on 2008-10-01
8
198 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
PRTG Network Monitor: Intuitive Network Monitoring

Network Monitoring is essential to ensure that computer systems and network devices are running. Use PRTG to monitor LANs, servers, websites, applications and devices, bandwidth, virtual environments, remote systems, IoT, and many more. PRTG is easy to set up & use.

 
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

Ransomware: The New Cyber Threat & How to Stop It

This infographic explains ransomware, type of malware that blocks access to your files or your systems and holds them hostage until a ransom is paid. It also examines the different types of ransomware and explains what you can do to thwart this sinister online threat.  

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
VB error "Type mismatch" 2 55
JSON Response and request in VB6 application 11 424
fso.FolderExists("\\server\HiddenFolder$") 4 66
Advice in Xamarin 21 79
If you have ever used Microsoft Word then you know that it has a good spell checker and it may have occurred to you that the ability to check spelling might be a nice piece of functionality to add to certain applications of yours. Well the code that…
When designing a form there are several BorderStyles to choose from, all of which can be classified as either 'Fixed' or 'Sizable' and I'd guess that 'Fixed Single' or one of the other fixed types is the most popular choice. I assume it's the most p…
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…

777 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