Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 160
  • Last Modified:

Excel 2003 - Array Bound Error

The below code works fine.

In a subsequent module the following line produces an error ONLY when the number of rows in UniqFoRsArr = 1 (i.e. it works fine for rows > 1)

ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 3) ' add col 2 for rating, 3 for RCI
' assemble unique FoRs from FoRArts into UniqFoRsArr

Dim UniqFoRsArr(), FoRArtCounter, UniqueCounter, Test, NumRecs, AddRec, tempArr
ReDim UniqFoRsArr(1, 1)
NumRecs = 1     'tracks number of rows in UniqFoRsArr
AddRec = True   'discriminates whether to add new row to UniqFoRsArr
For FoRArtCounter = 1 To UBound(FoRArts, 1) 'FoRArts is list of arts related to strMainFoR
    For Each FieldItem In Array(10, 13, 16)
        Test = FoRArts(FoRArtCounter, FieldItem)
        If Test <> "" And Test <> strMainFoR Then  'caters for blanks and matches with strMainFoR
            For UniqueCounter = 1 To UBound(UniqFoRsArr, 2) 'cycle thru UniqFoRsArr
                If UniqFoRsArr(1, UniqueCounter) = Test Then
                    AddRec = False  'if FoR exists then don't add new record
                End If
            Next UniqueCounter
            If AddRec Then
                UniqFoRsArr(1, NumRecs) = Test   'add the record
                NumRecs = NumRecs + 1           'increment row count in UniqFoRsArr
                ReDim Preserve UniqFoRsArr(1, NumRecs) ' need to transpose
            End If
        End If
        AddRec = True
    Next FieldItem
Next FoRArtCounter
ReDim Preserve UniqFoRsArr(1, UBound(UniqFoRsArr, 2) - 1) 'remove trailing row
tempArr = Application.Transpose(UniqFoRsArr)
UniqFoRsArr = tempArr                    ' now UniqFoRsArr contains only unique list of FoRs
End Sub

Open in new window

0
TigerMan
Asked:
TigerMan
  • 11
  • 8
1 Solution
 
Rory ArchibaldCommented:
How have you declared and initialised the array? (I suspect it's not actually an array when there's only one element - eg you assigned a range value to a variant).
0
 
TigerManAuthor Commented:
Dim UniqFoRsArr()
ReDim UniqFoRsArr(1, 1)

That's it ... UniqFoRsArr is also declared up top as
Dim UniqFoRsArr

0
 
Rory ArchibaldCommented:
Why is it declared twice? That gives you two different variables.
0
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.

 
TigerManAuthor Commented:
ok, so removed the Dim from the block of code above ... still crashes when the number of rows is 1, but works fine if 2 or more ... got me buggered :)
0
 
Rory ArchibaldCommented:
Do you have an Option Base 1 statement? If not, Then this:

ReDim UniqFoRsArr(1, 1)

Actually declares an array with 2 rows and 2 columns. Perhaps that is your issue?
0
 
TigerManAuthor Commented:
i do have Option Base 1

this problem has tied me up for 6 hours now ... unbelievable :)
0
 
Rory ArchibaldCommented:
In fact, it almost certainly is as Transpose will return a 1 based array, so you'd get back an array from 1 to 2 on each dimension, rather than 0 to 1.
0
 
TigerManAuthor Commented:
All I am trying to do with
ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 3)
is simply add two new columns to UniqFoRsArr

Preserve keeps the data intact

When this ReDim is called UniqFoRsArr has 1 column of data by n rows (where n is between 1 and 157)
If n is > 1 then the ReDim works, and everything moves forward correctly
If n = 1 then the ReDim statement returns 'Subscript out of Range'
0
 
Rory ArchibaldCommented:
This:
ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 3)

is not in the code you posted as far as I can see. If it's in another module, then your problem is that UniqFoRsArr only has scope in the routine you posted above - as soon as that finishes, it gets erased. With your original double declaration, the variable existed outside this routine, but was not changed by it.

As an aside, if you are just trying to get a unique list of items, I think a Dictionary object would be a lot faster.
0
 
TigerManAuthor Commented:
This: ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 3) is within the same module.
I have Watched it populate etc in the above code chunk.  A more complete code chunk is attached.
It is at line XXX that the error occurs, but only when UBound(UniqFoRsArr,1) is = 1.

If we can resolve this tiny problem then I will up the points and ask more about the Dictionary thingy ... that is something I do not understand.


' ******************************************************************************************
' assemble unique FoRs from FoRArts into UniqFoRsArr

Dim FoRArtCounter, UniqueCounter, Test, NumRecs, AddRec, tempArr
ReDim UniqFoRsArr(1, 1)

NumRecs = 1     'tracks number of rows in UniqFoRsArr
AddRec = True   'discriminates whether to add new row to UniqFoRsArr
For FoRArtCounter = 1 To UBound(FoRArts, 1) 'FoRArts is list of arts related to strMainFoR
    For Each FieldItem In Array(10, 13, 16)
        Test = FoRArts(FoRArtCounter, FieldItem)
        If Test <> "" And Test <> strMainFoR Then  'caters for blanks and matches with strMainFoR
            For UniqueCounter = 1 To UBound(UniqFoRsArr, 2) 'cycle thru UniqFoRsArr
                If UniqFoRsArr(1, UniqueCounter) = Test Then
                    AddRec = False  'if FoR exists then don't add new record
                End If
            Next UniqueCounter
            If AddRec Then
                UniqFoRsArr(1, NumRecs) = Test   'add the record (column)
                NumRecs = NumRecs + 1           'increment row count in UniqFoRsArr
                ReDim Preserve UniqFoRsArr(1, NumRecs) ' add new column, need to transpose
            End If
        End If
        AddRec = True
    Next FieldItem
Next FoRArtCounter
ReDim Preserve UniqFoRsArr(1, UBound(UniqFoRsArr, 2) - 1) 'remove trailing row (column)
tempArr = Application.Transpose(UniqFoRsArr)
UniqFoRsArr = tempArr                    ' now UniqFoRsArr contains only unique list of FoRs
XXX ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 3)

Call BubbleSort(UniqFoRsArr, True)       ' true is ascending order, false is descending

Open in new window

0
 
Rory ArchibaldCommented:
Do you have an Option Base 1 statement?

Your code should not work for any number of rows for the reasons I stated earlier.

This line:
ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 3)

tries to resize and preserve an array. However, when you use Redim and Preserve, you cannot change the boundary of any dimension other than the last one. Transpose returns a 1 based array, but you are resizing without specifying a lower bound of 1, so you are effectively trying to resize the first dimension, and that is not allowed.

To simplify your issue, consider this code:
   Dim UniqFoRsArr()
   Dim tempArr
   Dim numrows           As Long
   numrows = 1
   ReDim UniqFoRsArr(1, 1)   ' <<-- your array is now UniqFoRsArr(0 to 1, 0 to 1)

   tempArr = Application.Transpose(UniqFoRsArr)
   UniqFoRsArr = tempArr   ' <<-- your array is now UniqFoRsArr(1 to 2, 1 to 2)

   ' this will fail because you are trying to alter the FIRST dimension (to be 0 to 2) as well as theLAST dimension.
   ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 3)


   ' this will work because you are not changing the size of the FIRST dimension any more
   ' note that BOTH dimensions are declared using '1 to n' syntax
   ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To 3)

Open in new window

0
 
TigerManAuthor Commented:
hi again ... ok, i have an hour to play
i think this is on the right track ... it has to be a declaration / bound type problem ... but not yet fixed

see below code ... both *** ReDim statements work fine no matter how many records are in UniqFoRsArr

the ### ReDim statement still crashes !!

it must be an error in this code because 50 lines further down the following code also works fine

ReDim Preserve UniqFoRsArr(UBound(UniqFoRsArr, 1), 15)

i.e. i just keep adding columns to UniqFoRsArr until i get it the way i want it to be.

Any more clues?
ReDim UniqFoRsArr(1 To 1, 1 To 1)

NumRecs = 1     'tracks number of rows in UniqFoRsArr
AddRec = True
For FoRArtCounter = 1 To UBound(FoRArts, 1)
SNIP Code
            If AddRec Then
                UniqFoRsArr(1, NumRecs) = Test
                NumRecs = NumRecs + 1
***          ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To NumRecs)
            End If
Next FoRArtCounter
*** ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To UBound(UniqFoRsArr, 2) - 1)
tempArr = Application.Transpose(UniqFoRsArr)
UniqFoRsArr = tempArr
### ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To 3)

Open in new window

0
 
TigerManAuthor Commented:
Also as stated above I do use Option Base 1
0
 
Rory ArchibaldCommented:
Ah, got it. If your array is (1 to 1, 1 to 1) then Transpose returns an array that is just (1 to 1), which is why the Redim Preserve fails. I'd change the code to this:

   ReDim UniqFoRsArr(1 To 1, 1 To 1)

   NumRecs = 1     'tracks number of rows in UniqFoRsArr
   AddRec = True
   For FoRArtCounter = 1 To UBound(FoRArts, 1)
      'SNIP Code
      If AddRec Then
         ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To NumRecs)   '***
         UniqFoRsArr(1, NumRecs) = Test
         NumRecs = NumRecs + 1
      End If
   Next FoRArtCounter
   If UBound(UniqFoRsArr, 1) > 1 Or UBound(UniqFoRsArr, 2) > 1 Then
      tempArr = Application.Transpose(UniqFoRsArr)
      UniqFoRsArr = tempArr
   End If
   ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To 3)   '###

Open in new window

0
 
TigerManAuthor Commented:
hi rorya
i have messed about with this, and it now works ... testing for columns before ReDim was the answer - i just couldn't see it so thanks!
this one has cost you a bit of time so my apologies
i am quite happy to increase the points
i also would like some advice with this dictionary thing ... i saw it elsewhere but it has not been explained clearly
can you post an example of taking an array (with repeating values) and shoving a unique set of values in this dictionary thing?  something on how to use the dictionary once it has those unique values would be cool as well
you tell me how many points this is worth then ... cool?
0
 
TigerManAuthor Commented:
btw, here is the complete and final code block :)
' ******************************************************************************************
' assemble unique FoRs from thisFoRArts into UniqFoRsArr

Dim FoRArtCounter, UniqueCounter, Test, AddRec, tempArr
ReDim UniqFoRsArr(1 To 1, 1 To 1)

NumRecs = 1     'tracks number of rows in UniqFoRsArr
AddRec = True   'discriminates whether to add new row to UniqFoRsArr

' outer loop through each article in thisFoRArts (all articles related to strMainFoR)
For FoRArtCounter = 1 To UBound(thisFoRArts, 1)
' inner loop through the 3 fields that contain 4FoR values or blanks
    For Each FieldItem In Array(10, 13, 16)
        Test = thisFoRArts(FoRArtCounter, FieldItem) ' load Test with 4FoR
        If Test <> "" And Test <> strMainFoR Then  ' caters for blanks and matches with strMainFoR
            ' loop through each record in UniqFoRsArr to determine existence of Test
            For UniqueCounter = 1 To UBound(UniqFoRsArr, 2)
                If UniqFoRsArr(1, UniqueCounter) = Test Then
                    AddRec = False  ' if FoR in UniqFoRsArr then don't add new record
                End If
            Next UniqueCounter
            ' AddRec set to True outside loop; set to false if Test is blank or in UniqFoRsArr above
            ' therefore if true proceed to add new record and increment the record counter
            If AddRec Then
                ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To NumRecs) ' new column, need transpose
                UniqFoRsArr(1, NumRecs) = Test   'add the record (column)
                NumRecs = NumRecs + 1           'increment row count in UniqFoRsArr
            End If
        End If
        AddRec = True
    Next FieldItem
Next FoRArtCounter

' in cases where there is either 0 or 1 record in UniqFoRsArr, don't bother resize/ReDim
If UBound(UniqFoRsArr, 1) > 1 Or UBound(UniqFoRsArr, 2) > 1 Then
    tempArr = Application.Transpose(UniqFoRsArr)
    UniqFoRsArr = tempArr
End If
ReDim Preserve UniqFoRsArr(1 To UBound(UniqFoRsArr, 1), 1 To 3) 'add 2 new columns
' ******************************************************************************************

Open in new window

0
 
TigerManAuthor Commented:
hi rory, how would you like me to proceed with this?
0
 
Rory ArchibaldCommented:
I'd suggest you close this question then start a new one about the Dictionary. Or just have a read of Patrick's article here: http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/A_3391-Using-the-Dictionary-Class-in-VBA.html
0
 
TigerManAuthor Commented:
ok so a few more points ... thanks rory
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 11
  • 8
Tackle projects and never again get stuck behind a technical roadblock.
Join Now