I have the following code which crashes excel when run:
Option Explicit
Private Type Calculations
x As Double
x2 As Double
x3 As Double
x4 As Double
x5 As Double
h1 As Double
v1 As Double
a1 As Double
p1 As Double
h2 As Double
v2 As Double
a2 As Double
p2 As Double
h3 As Double
v3 As Double
a3 As Double
p3 As Double
h4 As Double
v4 As Double
a4 As Double
p4 As Double
h5 As Double
v5 As Double
a5 As Double
p5 As Double
End Type
Private Type Points
Point() As Calculations
End Type
Private Type Sections
Section() As Points
End Type
Function DynamicRedim()
Dim aSections As Sections
Dim aCalculations As Calculations
Dim aPoints() As Points
Dim i As Integer
Dim aSectionsDimension As Integer
Dim aPointsDimension As Integer
Dim aSectionsCount As Integer
Dim aPointsCount As Integer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
aSectionsDimension = 1
aPointsDimension = 5
ReDim Preserve aSections.Section(aSectionsDimension)
aPoints = aSections.Section()
ReDim Preserve aPoints(aPointsDimension)
For i = LBound(aSections.Section) To UBound(aSections.Section)
aSections.Section(i).Point = aPoints
Next
For aSectionsCount = LBound(aSections.Section) To UBound(aSections.Section) '<< believe crash occurs when aSectionsCount = UBound(aSections.Section)?????
For aPointsCount = LBound(aSections.Section(aSectionsCount).Point) To UBound(aSections.Section(aSectionsCount).Point)
aSections.Section(aSectionsCount).Point(aPointsCount).x = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).x5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p1 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p2 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p3 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p4 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).h5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).v5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).a5 = 0
aSections.Section(aSectionsCount).Point(aPointsCount).p5 = 0
Next
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
I added the nested for loops towards the end of the function to zero all the elements in the type. Before I added this step, I noticed the elements towards the end (ie v4,a4,p4,h4,v5,a5,p5,h5) somehow ended up with some really strange values - random numbers to power e-211.
Clearly I did not set these values but equally I don't want them either!!
This aside, the code should not crash excel either...I'm pretty certain that this occurs then the outer for loop reaches UBound(aSections.Section).
I cannot see any reason why this would do this. I've tried two separate computers to eliminate any computer related issues and it looks to be code related.
Can anyone suggest a fix for this?
Point and Points are both Excel Classes. It is always a bad idea to use the name of an Excel data type as the name of one of your variables. However, I do not believe that is the cause of the crash.
DynamicRedim does not return a value so it is a Sub not a Function. This is not important since you are not trying to return a value.
I believe the first problem is:
aPoints = aSections.Section()
Both aPoints and aSections.Section() are arrays of Points but they are defined in different ways. I suspect the alignment is slightly different and memory is being corrupted.
I believe the same sort of memory corruption occurs with:
For i = LBound(aSections.Section) To UBound(aSections.Section)
aSections.Section(i).Point = aPoints
Next
When I single step through your code, Excel crashes halfway down the first loop. It is possible to obtain the address of an Excel variable so we could perform a detailed investigation and prove the problem is corrupted memory but I do not think it would be worth the time.
Your problem is that you are trying to ReDim an array by copying a predefined array to it. I have copied arrays successfully but with the source and destination arrays having an identical definition. You cannot ReDim an array of arrays in the conventional way but you can ReDim aSections.Section(i).Point.
I have rewritten your code so it works. I have included an explanation for each of my changes. Come back with questions if those explanations are not adequate.
Option Explicit
Private Type Calculations
x As Double
x2 As Double
x3 As Double
x4 As Double
x5 As Double
h1 As Double
v1 As Double
a1 As Double
p1 As Double
h2 As Double
v2 As Double
a2 As Double
p2 As Double
h3 As Double
v3 As Double
a3 As Double
p3 As Double
h4 As Double
v4 As Double
a4 As Double
p4 As Double
h5 As Double
v5 As Double
a5 As Double
p5 As Double
End Type
' Every use of "Point" replaced by "Pnt" to avoid any conflict
' with Excel classes Point and Points
Private Type Pnts
Pnt() As Calculations
End Type
Private Type Sections
Section() As Pnts
End Type
Function DynamicRedim2()
Dim aSections As Sections
'Dim aCalculations As Calculations ' Not used by this code
'Dim aPoints() As Points ' Not used by this code
Dim i As Integer
Dim aSectionsDimension As Integer
Dim aPntsDimension As Integer
Dim aSectionsCount As Integer
Dim aPntsCount As Integer
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
aSectionsDimension = 1
aPntsDimension = 5
' Removed Preserve because nothing to preserve
ReDim aSections.Section(aSectionsDimension)
' Use ReDim to size array rather than copying array of correct size
' Note: if "aSections.Section(i)" was an array, you cannot ReDim
' in this way because the syntax is invalid. You must pass
' "aSections.Section(i)" to a subroutine which can ReDim it. If this
' in not clear, I will construct an example to show what I mean.
For i = LBound(aSections.Section) To UBound(aSections.Section)
ReDim aSections.Section(i).Pnt(aPntsDimension)
Next
' Display aSections to show already initialised to zeros. VBA initialises
' all variables to a default value.
Call DsplSection(aSections)
For aSectionsCount = LBound(aSections.Section) To UBound(aSections.Section)
For aPntsCount = LBound(aSections.Section(aSectionsCount).Pnt) To _
UBound(aSections.Section(aSectionsCount).Pnt)
' I have changed the zeros to non-zero values to prove the code is
' changing all the elements.
' "1" is stored as an Integer and will have to be converted to a Double
' for each statement for each loop. "1#" tells the compiler to store 1
' as a Double.
aSections.Section(aSectionsCount).Pnt(aPntsCount).x = 1#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x2 = 2#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x3 = 3#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x4 = 4#
aSections.Section(aSectionsCount).Pnt(aPntsCount).x5 = 5#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h1 = 6#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v1 = 7#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a1 = 8#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p1 = 9#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h2 = 10#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v2 = 11#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a2 = 12#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p2 = 13#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h3 = 14#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v3 = 15#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a3 = 16#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p3 = 17#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h4 = 18#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v4 = 19#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a4 = 20#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p4 = 21#
aSections.Section(aSectionsCount).Pnt(aPntsCount).h5 = 22#
aSections.Section(aSectionsCount).Pnt(aPntsCount).v5 = 23#
aSections.Section(aSectionsCount).Pnt(aPntsCount).a5 = 24#
aSections.Section(aSectionsCount).Pnt(aPntsCount).p5 = 25#
Next
Next
' Display new values
Call DsplSection(aSections)
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Function
Sub DsplSection(ByRef SectionCrnt As Sections)
' For VBA, "Integer" specifies a 16-bit integer while "Long" defines a
' 32-bit integer. Integer variable are supposed to take longer to process
' than Long variable on 32-bit and 64-bit computers. VBA routines are
' difficult to time because of all the background processing that can occur
' at any time. My experiments have failed to detect any difference between
' Integer and Long variables. However, no harm in having the bigger variable.
Dim InxS As Long
Dim InxP As Long
For InxS = LBound(SectionCrnt.Section) To UBound(SectionCrnt.Section)
For InxP = LBound(SectionCrnt.Section(InxS).Pnt) To _
UBound(SectionCrnt.Section(InxS).Pnt)
Debug.Print InxS & " " & InxP & ": ";
' Note how much typing you save using a With statement
With SectionCrnt.Section(InxS).Pnt(InxP)
Debug.Print .x & " " & .x2 & " " & .x3 & " " & .x4 & " " & .x5 & " " & _
.h1 & " " & .v1 & " " & .a1 & " " & .p1 & " " & .h2 & " " & _
.v2 & " " & .a2 & " " & .p2 & " " & .h3 & " " & .v3 & " " & _
.a3 & " " & .p3 & " " & .h4 & " " & .v4 & " " & .a4 & " " & _
.p4 & " " & .h5 & " " & .v5 & " " & .a5 & " " & .p5
End With
Next
Next
End Sub
Related
I ask the user to put an input number like a "max" and then count and add all the even numbers together. For example: If the user inputs 6 then that would be 2+4+6 = 12
Sub AddupEvenNumbers()
Dim num As Variant
Dim evennum As Variant
Dim sum As Double
Dim str As String
Dim count As Integer
str = "Enter a upper/maximum number "
num = InputBox(str)
evennum = num
If num Mod 2 Then
evennum = num.Value + num
count = count + 1
End If
MsgBox "The sum of even numbers " & vbNewLine & "from 0 to " & num & vbNewLine & "is " & evennum
End Sub
you need to loop using a For loop and step 2:
Sub AddupEvenNumbers()
Dim num As Variant
Dim evennum As Long
Dim sum As Double
Dim str As String
Dim count As Integer
str = "Enter a upper/maximum number "
Do
num = InputBox(str)
If Not IsNumeric(num) Then str = "Must be a number." & vbNewLine & "Enter a upper/maximum number "
Loop While Not IsNumeric(num)
sum = 0
For evennum = 0 To num Step 2
sum = sum + evennum
Next evennum
MsgBox "The sum of even numbers " & vbNewLine & "from 0 to " & num & vbNewLine & "is " & sum
End Sub
Or use Application.InputBox(str,Type:= 1) to force a numeric entry
Sub AddupEvenNumbers()
Dim num As Double
Dim evennum As Long
Dim sum As Double
Dim str As String
Dim count As Integer
str = "Enter a upper/maximum number "
num = Application.InputBox(str, Type:=1)
sum = 0
For evennum = 0 To num Step 2
sum = sum + evennum
Next evennum
MsgBox "The sum of even numbers " & vbNewLine & "from 0 to " & num & vbNewLine & "is " & sum
End Sub
No need for VBA. You can use a formula:
With the entered number in A1:
=SUM(SEQUENCE(A1)*ISEVEN(SEQUENCE(A1)))
In earlier versions of Excel, you can use an array-formula:
=SUM(ISEVEN(ROW(INDEX(A:A,1):INDEX(A:A,A1)))*ROW(INDEX(A:A,1):INDEX(A:A,A1)))
In some earlier versions of Excel, you may need to "confirm" this array-formula by holding down ctrl + shift while hitting enter. If you do this correctly, Excel will place braces {...} around the formula as observed in the formula bar
In answer to your question how to count even numbers less than a number (presumably over zero):
num / 2 + 1
To answer to how to sum these numbers: we know that opposite pairs of these values will sum to the original value (so for 6.... 4,2 = 6. So the number of pairs is half of the count from the previous calculation, multiplied by the num value.
(num / 2 + 1) / 2 * num
Combined with your implied question about handling user errors, see code below for a suggested route I might use. Note I never use mod to test if somethign is even due to the fact that it forces the value to convert to a Long (see my Stack Overflow debut question on that topic... as it WILL error out if number is too big). So I use an int comparison shown below which also rejects decimals.
Sub ExampeEntry()
Dim aResponse As String, aNumberResponse As Long
start:
aResponse = Replace(InputBox("Enter An Even Number"), ",", "") 'or "." if Europe
If aResponse = "" Then
'User cancelled/didn't enter
ElseIf IsNumeric(aResponse) Then
If Int(aResponse / 2) <> aResponse / 2 Then
MsgBox aResponse & " is not an even number..."
GoTo start
Else
'success
aNumberResponse = aResponse
MsgBox (aNumberResponse / 2 + 1)/2 * aNumberResponse
End If
Else
MsgBox "ummm... """ & aResponse & """ isn't a number my friend...", vbCritical, "oh boy..."
GoTo start
End If
End Sub
I'm trying to turn general data written as fractions like 3/4" or 13 7/32" into 3 place decimal numbers such as 0.750 or 13.219.
I have a working table replacement that handles 0 to 1" fractions. It can't handle the mixed numbers like 13 7/32". It leaves me with 13 0.219 which is why I need to replace " 0." with "." to join the 13 and 219 together with a decimal.
We do this data conversion in multiple steps and hand type because Excel tries converting some fractions like 3/4" into a date.
Original data
Resulting data
Sub FractionConvertMTO()
'this section works
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
Selection.Replace what:=Cells(i, 21).Value, Replacement:=Cells(i, 22).Value, _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
Next
'this section doesn't work
For i = 6 To 70
Worksheets("BOM").Range("F6:H48").Select
str1 = " "
str1 = Trim(Replace(str1, " ", "+"))
Next
'this section changes the format.
For i = 66 To 130
Range("F6:H48").NumberFormat = "0.000"
Next
'this section is supposed to add an = sign in front of the cell contents but doesn't work.
Dim Cell As Range
For Each Cell In Range("F6:H48")
Cell.Value = "=" & Cell.Value
Next Cell
'this section works to highlight the first cell
Worksheets("BOM").Cells(1, 1).Select
End Sub
I dug up the following method from my library of useful functions. It converts numbers represented as a fractional string to the numeric equivalent. Simply loop through the cells needing conversion and call this method:
Public Function FractionToNumber(ByVal Value As String, Optional ByVal Digits As Long = 0) As Double
Dim P As Integer
Dim N As Double
Dim Num As Double
Dim Den As Double
Value = Trim$(Value)
P = InStr(Value, "/")
If P = 0 Then
N = Val(Value)
Else
Den = Val(Mid$(Value, P + 1))
Value = Trim$(Left$(Value, P - 1))
P = InStr(Value, " ")
If P = 0 Then
Num = Val(Value)
Else
Num = Val(Mid$(Value, P + 1))
N = Val(Left$(Value, P - 1))
End If
End If
If Den <> 0 Then N = N + Num / Den
FractionToNumber = Round(N, Digits)
End Function
You may also code something like the following:
Sub FractionConvertMTO()
Dim rng As Range
Dim Arr As Variant
Arr = Worksheets("MTO").Range("F6:H48")
For Row = 1 To UBound(Arr, 1)
For col = 1 To UBound(Arr, 2)
str1 = Arr(Row, col)
pos1 = InStr(str1, " ")
pos2 = InStr(str1, "/")
If pos2 = 0 Then
N = val(str1)
Num = 0: Den = 1
Else
If pos1 And pos1 < pos2 Then
N = val(Left$(str1, pos1 - 1))
Num = val(Mid$(str1, pos1 + 1))
Else
N = 0
Num = val(Left$(str1, pos2 - 1))
End If
Den = val(Mid$(str1, pos2 + 1))
End If
Arr(Row, col) = N + Num / Den
Next col
Next Row
Worksheets("MTO").Range("F6", "H48") = Arr
End Sub
If you dispose of the newer dynamic array features (vers. 2019+,MS365) you might write the results in one go to the entire original range (target range) as follows (overwriting the existing range; otherwise define a given offset to identify another target range: rng.Offset(,n)=..).
Tip: make a backup copy before testing (as it overwrites rng)!
Note that this example assumes the " character (asc value of 34).
A) First try via tabular VALUE() formula evaluation
Caveat: converting blanks by VALUE() would be written as #VALUE! results, which would need a further loop. To avoid this you can prefix a zero to the formulae myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))" so that results would be displayed as zero.
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) define tabular formula
Dim myFormula As String
'myFormula = "=VALUE(SUBSTITUTE(" & rng.Address & ","""""""",""""))"
'Alternative to avoid #VALUE! displays for blanks:
myFormula = "=VALUE(SUBSTITUTE(" & """0""&" & rng.Address & ","""""""",""""))"
'Debug.Print myFormula
'3) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value2 = rng.Parent.Evaluate(myFormula)
End Sub
Conclusion due to comment:
Though fast, this approach has a big disadvantage: Excel interpretes date-like numbers as such, transforms them internally to dates by returning the numeric part here, so a cell input of 3/4" would return the corresponding date value of the current year for March 4th.
B) Reworked code based on direct cell evaluations in a loop //Edit
Similar to the above processing this approach is also based on evaluation, but collects all formulae as strings in a variant datafield array v, which allows to manipulate and evaluate each cell input individually:
Sub ChangeToFractionValues()
'1) define original range to be replaced
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("BOM").Range("F6:H48")
'2) assign formula strings to variant 1-based 2-dim data field array
Dim v As Variant
v = rng.Formula2
'3) evaluate results in a loop
Dim i As Long, j As Long
For i = 1 To UBound(v)
For j = 1 To UBound(v, 2)
v(i, j) = Evaluate("0" & Replace(v(i, j), Chr(34), ""))
Next j
Next i
'4) overwrite original range (otherwise code an offset rng.Offset(,n).Value = ...
rng.Value = v
End Sub
str1 = trim(Replace(str1, "0.", "."))
I'm trying to create a function that calculates Drawdown.
It would work as follows:
I have a series of quotes for a specific stock in column B: B (example)
I want to know the maximum drawdown, that is, how much would be the biggest decrease in the quote.
In this case the biggest indentation occurs in the yellow area!that is, the formula would look like: Drawdown = (MaxValue/Value)-1 ==> Drawdown = (13/9)-1
I tried as follows, with no result:
Public Function MDD(ByVal Selection0, ByVal Selection1)
'Function Max DrawDown
Dim i As Long
Dim Drawdown0 As Long
Dim Drawdown1 As Long
i = 2
Drawdown0 = "(" & Selection0 & "/MAX(" & Selection1 & ")) - 1"
While i < Plan1.Range("B" & Rows.Count).End(xlUp).Row + 1
Drawdown1 = "(" & Selection0 & "/MAX(" & Selection1 & ")) - 1"
If Drawdown1 > Drawdown0 Then
Drawdown0 = Drawdown1
End If
i = i + 1
Wend
MDD = Drawdown0
End Function
Sub lsMDD()
Application.MacroOptions Macro:="MDD", Category:=4
End Sub
Where's the error?
You don't need to iterate over the range. Look at Application.WorksheetFunction - it's got everything you need.
Public Function MDD(ByVal pRange As Variant) As Variant
MDD = Application.WorksheetFunction.Max(pRange) / Application.WorksheetFunction.Min(pRange) - 1
End Function
I need to add brackets around the numbers in a string found in cells on my Excel worksheet.
For example, say I am given:
913/(300+525)
I need to get this in return:
[913]/([300]+[525])
The equations are fairly simple, should only have to deal with + - * / ( ) characters.
I attempted looping through the string character by character using the MID function but I can't get the loop(s) working correctly and end up getting a jumbled mess of random brackets and numbers back. I also considered using regular expressions but I've never used them before and have no idea if this would be a good application.
Please let me know if you need anything else. Thank you for your time!
They can be decently long. Here is another example:
I have:
(544+(1667+1668+1669+1670+1671+1672+1673)-1674)
But I need:
([544]+([1667]+[1668]+[1669]+[1670]+[1671]+[1672]+[1673])-[1674])
I just threw this together but it should work
Function generateBrackets(Equation As String) As String
Dim temp As String
Dim brackets As Boolean
Dim x 'If we're using Option Explicit, or just to be safe
For x = 1 To Len(Equation)
If Not IsNumeric(Mid(Equation, x, 1)) And brackets = False Then
temp = temp & Mid(Equation, x, 1)
ElseIf Not IsNumeric(Mid(Equation, x, 1)) And brackets = True Then
temp = temp & "]" & Mid(Equation, x, 1)
brackets = False
ElseIf IsNumeric(Mid(Equation, x, 1)) And brackets = False Then
temp = temp & "[" & Mid(Equation, x, 1)
brackets = True
ElseIf IsNumeric(Mid(Equation, x, 1)) And brackets = True Then
temp = temp & Mid(Equation, x, 1)
End If
Next x
generateBrackets = temp
End Function
Here is a way which caters for Decimal numbers.
'~~> Add here whatever operators your equation
'~~> is likely to have
Const delim As String = "+()-/"
Sub Sample()
Dim MyAr
Dim sSamp As String
sSamp = "(5.44+(16.67+1668+1669+1670+1671+1672+1673)-1674)"
MyAr = Split(GetNewString(sSamp))
For i = 0 To UBound(MyAr)
sSamp = Replace(sSamp, MyAr(i), "[" & MyAr(i) & "]")
Next i
Debug.Print sSamp
End Sub
Function GetNewString(s As String) As String
Dim sTemp As String
sTemp = s
For i = 1 To Len(delim)
sTemp = Replace(sTemp, Mid(delim, i, 1), " ")
Next i
Do While InStr(1, sTemp, " ")
sTemp = Replace(sTemp, " ", " ")
Loop
GetNewString = Trim(sTemp)
End Function
Input
"(5.44+(16.67+1668+1669+1670+1671+1672+1673)-1674)"
Output
([5.44]+([16.67]+[1668]+[1669]+[1670]+[1671]+[1672]+[1673])-[1674])
I am trying to soft code the output variables, so that I don't have to modify the VBA code each time i need to modify the outputs.
This is the code that works
Sub Working()
Dim cat(1 To 10)
Dim bat(1 To 10)
For i = 1 To 10
cat(i) = i * 10
bat(i) = i * 5
Next i
Sheet2.Range("A2:A11") = Application.Transpose(cat())
Sheet2.Range("B2:B11") = Application.Transpose(bat())
End Sub
This is the ideal way i would want to write, but doesnt work
Sub not_working()
Dim cat(1 To 10)
Dim bat(1 To 10)
For i = 1 To 10
cat(i) = i * 10
bat(i) = i * 5
Next i
a = 3
Do While Sheet1.Cells(a, 1) <> ""
OutVar = Sheet1.cells(a, 1) & "()"
Sheet3.Range( _
Cells(2, a - 2).Address, Cells(11, a - 2).Address _
) = Application.Transpose(Outvar)
a = a + 1
Loop
End Sub
' Sheet1.cells(3,1) = cat - these cells contain the variable names
' Sheet1.cells(4,1) = bat - these cells contain the variable names
Can someone please suggest if it is possible to do so?
If I understand your requirement correctly, a ragged array will meet it.
If you have a variable of type Variant, you can set that variable to, for example, an integer, a real, a string, a boolean or an array.
If you have an array of type Variant, you can set each element of that array to a different type of value.
In my code below, I have variant array Main. I set:
Main(0) to a 1D array,
Main(1) to a larger 1D array,
Main(2) to a 2D array,
Main(3) to a single integer,
Main(4) to the used range of a worksheet.
This is called a ragged array because each element is a different size.
Having loaded the array with values, I use a general routine to output each element of Main according to its nature.
Each of your 200-300 variables would become an element of Main.
Have a look at my code. This is only a brief introduction to what can be achieved with variant arrays. Come back with questions if you think I am heading in the correct direction but have not gone far enough.
Option Explicit
Sub DemoRaggedArray()
Dim InxDim As Long
Dim InxMain As Long
Dim InxWCol As Long
Dim InxWRow As Long
Dim Main() As Variant
Dim NumOfDim As Long
Dim Work() As Variant
ReDim Main(0 To 5)
Work = Array(1, "A", True)
Main(0) = Work
Main(1) = Array(2, "B", False, 1.2)
ReDim Work(1 To 2, 1 To 3)
Work(1, 1) = 1
Work(1, 2) = 2.5
Work(1, 3) = DateSerial(2012, 12, 27)
Work(2, 1) = True
Work(2, 2) = "String"
Main(2) = Work
Main(3) = 27
' Cells A1:C4 of the worksheet have been set to their addresses
Main(4) = WorksheetFunction.Transpose(Worksheets("Sheet2").UsedRange.Value)
For InxMain = LBound(Main) To UBound(Main)
Debug.Print "Type of Main(" & InxMain & ") is " & VarTypeName(Main(InxMain))
Select Case VarType(Main(InxMain))
Case vbEmpty, vbNull
' No value
Case Is >= vbArray
' Array
NumOfDim = NumDim(Main(InxMain))
Debug.Print " Main(" & InxMain & ") is dimensioned as: (";
For InxDim = 1 To NumOfDim
Debug.Print LBound(Main(InxMain), InxDim) & " To " & _
UBound(Main(InxMain), InxDim);
If InxDim < NumOfDim Then
Debug.Print ", ";
End If
Next
Debug.Print ")"
Select Case NumOfDim
Case 1
For InxWCol = LBound(Main(InxMain)) To UBound(Main(InxMain))
Debug.Print " (" & InxWCol & ")[" & _
VarTypeName(Main(InxMain)(InxWCol)) & "]";
Select Case VarType(Main(InxMain)(InxWCol))
Case vbEmpty, vbNull, vbArray
' No code to handle these types
Case Else
Debug.Print "=" & Main(InxMain)(InxWCol);
End Select
Next
Debug.Print
Case 2
For InxWRow = LBound(Main(InxMain), 2) To UBound(Main(InxMain), 2)
For InxWCol = LBound(Main(InxMain), 1) To UBound(Main(InxMain), 1)
Debug.Print " (" & InxWCol & "," & InxWRow & ")[" & _
VarTypeName(Main(InxMain)(InxWCol, InxWRow)) & "]";
Select Case VarType(Main(InxMain)(InxWCol, InxWRow))
Case vbEmpty, vbNull, vbArray
' No code to handle these types
Case Else
Debug.Print "=" & Main(InxMain)(InxWCol, InxWRow);
End Select
Next
Debug.Print
Next
Case Else
Debug.Print " There is no display code for this number of dimensions"
End Select
Case Else
' Single variable
Debug.Print " Value = " & Main(InxMain)
End Select
Next
End Sub
Public Function NumDim(ParamArray TestArray() As Variant) As Integer
' Returns the number of dimensions of TestArray.
' If there is an official way of determining the number of dimensions, I cannot find it.
' This routine tests for dimension 1, 2, 3 and so on until it get a failure.
' By trapping that failure it can determine the last test that did not fail.
' Coded June 2010. Documentation added July 2010.
' * TestArray() is a ParamArray because it allows the passing of arrays of any type.
' * The array to be tested in not TestArray but TestArray(LBound(TestArray)).
' * The routine does not validate that TestArray(LBound(TestArray)) is an array. If
' it is not an array, the routine return 0.
' * The routine does not check for more than one parameter. If the call was
' NumDim(MyArray1, MyArray2), it would ignore MyArray2.
Dim TestDim As Integer
Dim TestResult As Integer
On Error GoTo Finish
TestDim = 1
Do While True
TestResult = LBound(TestArray(LBound(TestArray)), TestDim)
TestDim = TestDim + 1
Loop
Finish:
NumDim = TestDim - 1
End Function
Function VarTypeName(Var As Variant)
Dim Name As String
Dim TypeOfVar As Long
TypeOfVar = VarType(Var)
If TypeOfVar >= vbArray Then
Name = "Array of type "
TypeOfVar = TypeOfVar - vbArray
Else
Name = ""
End If
Select Case TypeOfVar
Case vbEmpty
Name = Name & "Uninitialised"
Case vbNull
Name = Name & "Contains no valid data"
Case vbInteger
Name = Name & "Integer"
Case vbLong
Name = Name & "Long integer"
Case vbSingle
Name = Name & "Single-precision floating-point number"
Case vbDouble
Name = Name & "Double-precision floating-point number"
Case vbCurrency
Name = Name & "Currency"
Case vbDate
Name = Name & "Date"
Case vbString
Name = Name & "String"
Case vbObject
Name = Name & "Object"
Case vbError
Name = Name & "Error"
Case vbBoolean
Name = Name & "Boolean"
Case vbVariant
Name = Name & "Variant"
Case vbDataObject
Name = Name & "Data access object"
Case vbDecimal
Name = Name & "Decimal"
Case vbByte
Name = Name & "Byte"
Case vbUserDefinedType
Name = Name & "Variants that contain user-defined types"
Case Else
Name = Name & "Unknown type " & TypeOfVar
End Select
VarTypeName = Name
End Function
Output from DemoRaggedArray
Type of Main(0) is Array of type Variant
Main(0) is dimensioned as: (0 To 2)
(0)[Integer]=1 (1)[String]=A (2)[Boolean]=True
Type of Main(1) is Array of type Variant
Main(1) is dimensioned as: (0 To 3)
(0)[Integer]=2 (1)[String]=B (2)[Boolean]=False (3)[Double-precision floating-point number]=1.2
Type of Main(2) is Array of type Variant
Main(2) is dimensioned as: (1 To 2, 1 To 3)
(1,1)[Integer]=1 (2,1)[Boolean]=True
(1,2)[Double-precision floating-point number]=2.5 (2,2)[String]=String
(1,3)[Date]=27/12/2012 (2,3)[Uninitialised]
Type of Main(3) is Integer
Value = 27
Type of Main(4) is Array of type Variant
Main(4) is dimensioned as: (1 To 3, 1 To 4)
(1,1)[String]=A1 (2,1)[String]=B1 (3,1)[String]=C1
(1,2)[String]=A2 (2,2)[String]=B2 (3,2)[String]=C2
(1,3)[String]=A3 (2,3)[String]=B3 (3,3)[String]=C3
(1,4)[String]=A4 (2,4)[String]=B4 (3,4)[String]=C4
Type of Main(5) is Uninitialised
Note the date is displayed as "27/12/2012" because that is the default date format for my country. If you run this code, it will display in your country's default format.