Multi-Dimensional Array Preservation 3

[UnsolvedCoding]

I am having difficulty trying to save information into a multi-dimensional array. In a normal array I would use ReDim Preserve but that doesn't work with a multi-dimensional array, it keeps saying array is already dimensioned.

What I have is a sheet that has 5 columns and hundreds of rows. I am trying to get the info put into one array so that I can simply say that if myarray(3,1) = the cell value then range("G" & i).value = myarray(3,1) or whatever the value would be.

I can't get the array to function dynamically and even when I limit it to 2 dimensions it doesn't want to redim preserve. I don't want to manually code each portion of the array.

So what I am doing is taking the 5 columns, the first 4 of which are client specific and column 5 which is a contact name, transfer it to a new sheet and then if one of the first 4 match put in the contact name in the appropriate cell.

Any ideas on how to fix this or work around it?

 

[SkipVought]

hi,

Please post the code where you declare your array and where you ReDim your array.

I'm always fascinated why people do not post code, but rather try to explain why their unposted code is not working.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[MajP]

Here is some code I have to dynamically add to a 1 and 2d arrays. You can only preserve the last dimension.

Public Sub Test1DAddElement()
  Dim aVar() As Variant
  'array not dimensioned
  aVar = AddElement(aVar, 1)
  Print1DArray (aVar)
  Debug.Print
  aVar = AddElement(aVar, 2)
  Print1DArray (aVar)
End Sub

Public Sub Test2DAddElement()
  Dim aVar() As Variant
  Dim vElements As Variant
  Dim numberElements As Integer
  vElements = Array("A", "B", "C")
  aVar = Add2DElement(aVar, vElements)
  Print2DArray (aVar)
  vElements = Array("D", "E", "F")
  aVar = Add2DElement(aVar, vElements)
  Debug.Print
  Print2DArray (aVar)
End Sub

Public Function AddElement(ByVal vArray As Variant, ByVal vElem As Variant) As Variant
      ' This function adds an element to a Variant array
      ' and returns an array with the element added to it.
      Dim vRet As Variant ' To be returned
      If IsEmpty(vArray) Or Not IsDimensioned(vArray) Then
          ' First time through, create an array of size 1.
          vRet = Array(vElem)
      Else
          vRet = vArray
          ' From then on, ReDim Preserve will work.
          ReDim Preserve vRet(UBound(vArray) + 1)
          vRet(UBound(vRet)) = vElem
      End If
      AddElement = vRet
  End Function
Public Function IsDimensioned(ByRef TheArray) As Boolean
      If IsArray(TheArray) Then ' we need to test it! otherwise will return false if not an array!
                      ' If you put extensive use to this function then you might modify
                      ' it a lil' bit so it "takes in" specific array type & you can skip IsArray
                      ' (currently you can pass any variable).
        On Error Resume Next
            IsDimensioned = ((UBound(TheArray) - LBound(TheArray)) >= 0)
        On Error GoTo 0
        'FYI: Erros are not always generated by Ubound & LBOund
        '     when array is empty (when arrays are "made" empty in some "specic way").
        '     So we cant use usual "decide" logic: bool = (err.number <> 0))
        'ie.:
        '    str = VBA.StrConv("", vbFromUnicode) 'generally you should use strconv when
        '                                          you plan converting string to bytearray,
        '                                          (here StrConv actually not needed for "",
        '                                          it's length is 0 anyway)
        '    ByteArr() = str
        '     UBound(ByteArr) => -1
        '     LBound(ByteArr) => 0
        'but:
        '    Erase ByteArr
        '     UBound(ByteArr) => Causes Error
        '     LBound(ByteArr) => Causes Error
        ' NOTE: I'm not sure, but I'm guessing (based on OnErr0r "knowledge" - > [url]http://www.xtremevbtalk.com/showthread.php?threadid=105700[/url])
        '    that "ByteArr() = str" will cause ByteArray point to SAFEARRAY in any case,
        '    even if "str" is empty while "Erase ByteArr" will remove that.
        ' QUESTION: can we make some how empty SAFEARRAYS for other types than
        '           ByteArrays as well????  I can't fiqure it out right now...
        '           Maybe doing something in low level...
    Else
        'IsDimensioned = False ' is already false by default
        Call Err.Raise(5, "IsDimensioned", "Invalid procedure call or argument. Argument is not an array!")
    End If
End Function

Public Function HasDimension(ByRef TheArray, Optional ByRef Dimension As Long = 1) As Boolean
    Dim isDim As Boolean
    Dim ErrNumb As Long
    Dim lb As Long
    Dim errDesc As String
    'HasDimension = False
    
    If (Dimension > 60) Or (Dimension < 1) Then
        Call Err.Raise(9, "HasDimension", "Subscript out of range. ""Dimension"" parameter is not in its legal borders (1 to 60)! Passed dimension value is: " & Dimension)
        Exit Function
    End If
    
    On Error Resume Next
        isDim = IsDimensioned(TheArray) 'IsArray & IsDimensioned in one call. If Err 5 will be generated if not Array
        ErrNumb = Err.Number
        If ErrNumb <> 0 Then
            errDesc = Err.Description
        End If
    On Error GoTo 0
    
    Select Case ErrNumb
        Case 0
            If isDim Then
                On Error Resume Next
                    lb = LBound(TheArray, Dimension) 'just try to retrive Lbound
                    HasDimension = (Err.Number = 0)
                On Error GoTo 0
            End If
        Case 5
            Call Err.Raise(5, "HasDimension", "Invalid procedure call or argument. Argument is not an array!")
        Case Else
            Call Err.Raise(vbObjectError + 1, "HasDimension", _
                "This is unexpected error, caused when calling ""IsDimensioned"" function!" & vbCrLf & _
                "Original error: " & ErrNumb & vbCrLf & _
                "Description:" & errDesc)
    End Select
End Function

[b]
Public Function Add2DElement(ByVal vArray As Variant, ByRef vElems As Variant) As Variant
      ' This function adds an element to a Variant array
      ' and returns an array with the element added to it.
      Dim vRet() As Variant ' To be returned
      Dim I As Integer
      Dim J As Integer
      If IsEmpty(vArray) Or Not IsDimensioned(vArray) Then
          ' First time through, create an array of size 1.
          ReDim vRet(0, UBound(vElems))
          For J = 0 To UBound(vElems)
            vRet(0, J) = vElems(J)
          Next J
      Else
          'Can not preserve with multi dim array. So create
          'new and copy.
          ReDim vRet(UBound(vArray, 1) + 1, UBound(vArray, 2))
          'fill from temp
          For I = LBound(vArray, 1) To UBound(vArray, 1)
            For J = LBound(vArray, 2) To UBound(vArray, 2)
              vRet(I, J) = vArray(I, J)
            Next J
          Next I
          For J = 0 To UBound(vElems)
            vRet(UBound(vRet), J) = vElems(J)
          Next J
      End If
      Add2DElement = vRet
  End Function
[/b]

Public Function RemoveFromArray(ByRef elements As Variant, ByVal element As Variant) As Variant()
  Dim NewArray() As Variant
  Dim I As Long
  Dim newi As Long
  ' Will create a new array where Element has been left out.
  'MsgBox UBound(Elements) - 1
  ReDim NewArray(LBound(elements) To UBound(elements) - 1)
   For I = LBound(elements) To UBound(elements)
      If elements(I) <> element Then
         'MsgBox element & " " & Elements(i)
         NewArray(newi) = elements(I)
         newi = newi + 1
      End If
   Next
   RemoveFromArray = NewArray
End Function

 

[UnsolvedCoding]

I have tried numerous variations of the redim preserve statment. Some of which are:
redim preserve MyArray(10,10)
redim preserve MyArray(a,a)
redim preserve MyArray()
redim preserve MyArray

The array is declared as a variant because some fields are numeric, others are strictly letters and others are alpha-numeric.

Dim MyArray(10, 10) As Variant

Dim A As Integer
Dim K As Long

A = 1
K = 1

Do

ReDim Preserve MyArray(K)

' A holds dept
MyArray(1, A) = Range("A" & K).Value


By the way Skip - From personal experience I can say that there are times people have requested code and other times people were irritated that I posted code for a single question.

 

[PHV]

A starting point:
Dim MyArray()
For K = 1 To NbRows
ReDim Preserve MyArray(5, K)
...
Next

Hope This Helps, PH.
FAQ219-2884
FAQ181-2886

 

[SkipVought]

Thank you for posting the code that otherwise anyone would have to GUESS.

    Dim [b]MyArray()[/b] As Variant
    
    Dim A As Integer
    Dim K As Long
    
    A = 1
    K = 1
    
    Do
    
        [b]ReDim Preserve MyArray(10, K)[/b]

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}

 

[UnsolvedCoding]

Thanks to all of you.

I can now plug in my row counter sub as the first dimensions, K as the second and use A to identify absolute values from the clients.

The code below is a simple test that runs, adapting it over is going very smoothly.

Thanks again.

For those of you that will read the code, there are no comments, its only a test sub. K and RowCount are declared as longs so that they can handle all rows on the new excel sheets.


Sub Test_Multi_Array()

Dim MyArray() As Variant
Dim A As Integer
Dim K As Long
Dim RowCount As Long

RowCount = 0
K = 2

Do

If Trim(Range("A" & K).Value) <> "" Then RowCount = RowCount + 1

K = K + 1

Loop Until IsEmpty(Range("A" & K).Value)

A = 1
K = 2

Do

ReDim Preserve MyArray(RowCount, K)

MyArray(1, A) = Range("A" & K).Value
MyArray(2, A) = Range("B" & K).Value
MyArray(3, A) = Range("C" & K).Value
MyArray(4, A) = Range("D" & K).Value
MyArray(5, A) = Range("E" & K).Value

K = K + 1
A = A + 1

Loop Until IsEmpty(Range("A" & K).Value)

K = 2
A = 1

Do

If A > UBound(MyArray) Then Exit Do

Range("G" & K).Value = MyArray(1, A)
Range("H" & K).Value = MyArray(2, A)
Range("I" & K).Value = MyArray(3, A)
Range("J" & K).Value = MyArray(4, A)
Range("K" & K).Value = MyArray(5, A)

K = K + 1
A = A + 1

Loop

End Sub

 

[SkipVought]

You might try something like this...

dim iCol as integer

Do

    ReDim Preserve MyArray(RowCount, K)

    for iCol = 1 to 5
       MyArray(iCol, A) = cells(K, iCol).Value
    next

    K = K + 1
    A = A + 1

Loop Until IsEmpty(Cells(K, 1).Value)

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}