Want to win a PS4? Go Premium and enter to win our High-Tech Treats giveaway. Enter to Win

x
?
Solved

Expand existing VB code

Posted on 2008-10-01
8
Medium Priority
?
206 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
  • 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
Independent Software Vendors: We Want Your Opinion

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

 
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 2000 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

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

Question has a verified solution.

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

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…
Since upgrading to Office 2013 or higher installing the Smart Indenter addin will fail. This article will explain how to install it so it will work regardless of the Office version installed.
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…
Suggested Courses

604 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