Convert a string reference to variable name - excel

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.

Related

Concatenate specific values from a cell with specific values from another cell into a particular format

A B C
1 numbers signs **Result**
2 *001* *alpha* 001-alpha
3 *001*111*221*104* *alpha*kappa*epislon*ETA* 001-alpha, 111-kappa, 221-epislon, 104-ETA
4 *001*085* *alpha*delta* 001-alpha, 085-delta
I'm trying to concatenate the values in columns A and B into the following format under the result section. Anything helps, thanks.
Formula solution
Using Textjoin and Filterxml function, of which Textjoin available in Office 365 or Excel 2019 and Filterxml available in Excel 2013 & later versions of Excel
In C2, array formula (confirm by pressing Ctrl+Shift+Enter) copied down :
=TEXTJOIN(", ",1,IFERROR(TEXT(FILTERXML("<a><b>"&SUBSTITUTE(A2,"*","</b><b>")&"</b></a>","//b"),"000")&FILTERXML("<a><b>"&SUBSTITUTE(B2,"*","</b><b>-")&"</b></a>","//b"),""))
I'm assuming this is doable with formulas but it might get unwieldy, so perhaps a UDF like this:
Public Function JoinNumbersAndSigns(ByVal numbersRng As Range, ByVal signsRng As Range) As String
Dim nums As String
nums = numbersRng.Cells(1).Value
nums = Mid$(nums, 2, Len(nums) - 2) ' remove leading and trailing *
Dim signs As String
signs = signsRng.Cells(1).Value
signs = Mid$(signs, 2, Len(signs) - 2) ' remove leading and trailing *
Dim tempNums As Variant
tempNums = Split(nums, "*")
Dim tempSigns As Variant
tempSigns = Split(signs, "*")
Dim i As Long
For i = LBound(tempNums) To UBound(tempNums)
Dim tempString As String
Dim sep As String
tempString = tempString & sep & tempNums(i) & "-" & tempSigns(i)
sep = ", "
Next i
JoinNumbersAndSigns = tempString
End Function
In Action:
The nums = Mid$(nums, 2, Len(nums) - 2) and similar line for signs could probably be made more robust, but should work given your current data.
Here's another approach using regular expressions ...
Option Explicit
Public Function Link(vNumbers As Range, vSigns As Range) As Variant
' ADD REFERENCE TO "Microsoft VBScript Regular Expressions 5.5"
Dim vRegEx As New RegExp
Dim vNumbersMatches As MatchCollection
Dim vSignsMatches As MatchCollection
Dim vCounter As Long
' The two parameters must only reference a single cell
If vNumbers.Cells.Count <> 1 Or vSigns.Cells.Count <> 1 Then
Link = CVErr(xlErrRef)
Exit Function
End If
' use regular expression to get the numbers
vRegEx.Pattern = "([0-9]+)"
vRegEx.Global = True
vRegEx.MultiLine = True
Set vNumbersMatches = vRegEx.Execute(vNumbers.Text)
' Use regular expression to get the signs
vRegEx.Pattern = "([^\*]+)"
vRegEx.Global = True
vRegEx.MultiLine = True
Set vSignsMatches = vRegEx.Execute(vSigns.Text)
' If the number of Numbers and Signs differs, then return an error
If vNumbersMatches.Count <> vSignsMatches.Count Then
Link = CVErr(xlErrValue)
Exit Function
End If
' Loop through the Numbers and Signs, appending each set
For vCounter = 0 To vNumbersMatches.Count - 1
Link = Link & vNumbersMatches.Item(vCounter) & "-" & vSignsMatches.Item(vCounter) & IIf(vCounter < vNumbersMatches.Count - 1, " ,", "")
Next
End Function
And the output ...
As long as there will always be a correlation between the number of elements in A & B this will work
Sub SplitandConcat()
' Declare working vars
Dim lRow As Long: lRow = 2
Dim sOutputString As String
Dim iWorkIndex As Integer
Dim CommaSpace As String
While ActiveSheet.Cells(lRow, 1) <> ""
CommaSpace = ""
'Split the incoming string on delimiter
arInput1 = Split(ActiveSheet.Cells(lRow, 1), "*")
arInput2 = Split(ActiveSheet.Cells(lRow, 2), "*")
' For each non blank item in the 1st array join the corresponding item int the second
For iWorkIndex = 0 To UBound(arInput1)
If arInput1(iWorkIndex) <> "" Then
ActiveSheet.Cells(lRow, 3) = ActiveSheet.Cells(lRow, 3) & CommaSpace & arInput1(iWorkIndex) & "-" & arInput2(iWorkIndex)
CommaSpace = ", "
End If
Next iWorkIndex
' check next row
lRow = lRow + 1
Wend
End Sub

Traverse thru array elements and extract delimited values when condition is satisfied

I want to loop thru an array and extract its delimited values that match every date in a range. For e.g., in the picture below:
I have a date range, say 01-01 to 01-10.
I also have a list of strings (see second pic).
In the array below (see first pic), I have three different values delimited by a semi-colon.
For all matching strings (from second pic) e.g., SISBTXTRPR-(number) and date, I want to extract the last part of the array value.
Picture 1
Picture 2
So, for all array values that match "SISBTXTRPR-4649" (the string from picture 2) and a date (in this case 12-12), I want to extract "2h" from the array. The date range for each string, in this case, "SISBTXTRPR-4649" will be 10 days. I am racking my brain on how to do this :(
This is all I could come up with so far:
While i < UBound(sTimeStamp)
If StrComp(Trim(Format(Now(), "MM-DD")), Trim(Split(sTimeStamp(9), ";")(1))) = 0 And StrComp(Trim(Worksheets("KPIs").Range("AN" & iCounter)), Trim(Split(sTimeStamp(1), ";")(0))) Then
End If
i = i + 1
Wend
Link to file
Sample File
The next code will return occurrences for each string in 'Task' range matching the date from its corresponding 'sTimeStamp Array' string with the one from the 'Date Range Array'. Each occurrence will be add to the next column of 'Task' string column:
Private Sub findOccurrences()
Dim sTask As Worksheet, sStamp As Worksheet, sDate As Worksheet
Dim arrTask As Variant, arrStamp As Variant, arrDate As Variant
Dim i As Long, j As Long, arrS As Variant, El As Variant, dtRef As Date
Set sTask = ThisWorkbook.Sheets("Task")
Set sStamp = ThisWorkbook.Sheets("sTimeStamp Array")
Set sDate = ThisWorkbook.Sheets("Date Range Array")
arrTask = sTask.Range("A2:A" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Value
arrStamp = sStamp.Range("A2:A" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Value
arrDate = sDate.Range("A2:A" & sDate.Range("A" & sDate.Rows.Count).End(xlUp).Row).Value
'____________________________________________________________________________
sTask.Range("B2:K" & sTask.Range("A" & sTask.Rows.Count).End(xlUp).Row).Clear
Do While i < UBound(arrStamp)
i = i + 1
arrS = Split(arrStamp(i, 1), ";")
For j = 1 To UBound(arrTask)
If arrS(0) = arrTask(j, 1) Then
For Each El In arrDate
dtRef = DateValue(Format(El, "MM-DD"))
If dtRef = DateValue(Format(arrS(1), "MM-DD")) Then
Debug.Print arrS(0) & " (row number " & j + 1 & "), interval """ & _
El & """ exists."
sTask.Cells(j + 1, sTask.Cells(j + 1, _
sTask.Columns.Count).End(xlToLeft).Column).Offset(0, 1).Value = El
End If
Next
End If
Next j
Loop
End Sub
And the short variant working similar to your approach, finding the occurrences for Today date (if I correctly deduced what you intended to achieve), replace the looping part with this:
'______________________________________________________________________________
sStamp.Range("B2:B" & sStamp.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Clear
sTask.Range("A2:A" & sTask.Range("A" & sStamp.Rows.Count).End(xlUp).Row).Interior.ColorIndex = -4142
While i < UBound(arrStamp)
i = i + 1
If StrComp(DateValue(Format(Date, "MM-DD")), DateValue(Split(arrStamp(i, 1), ";")(1))) = 0 And _
Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(1)), arrDate) Then
Debug.Print "OK for """ & Split(arrStamp(i, 1), ";")(0) & """ of row """ & i & """."
sStamp.Range("B" & i + 1).Value = "OK"
If Not isMatchErr(CStr(Split(arrStamp(i, 1), ";")(0)), arrTask) Then
rowOK = WorksheetFunction.Match(Split(arrStamp(i, 1), ";")(0), arrTask, 0) + 1
sTask.Range("A" & rowOK).Interior.ColorIndex = 3
End If
End If
Wend
And add the next function:
Function isMatchErr(strTime As String, arrDate As Variant) As Boolean
Dim k As Long
On Error Resume Next
k = WorksheetFunction.Match(strTime, arrDate, 0)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0: isMatchErr = True
End If
On Error GoTo 0
End Function
Besides the message in Immediate Window, an "OK" will be put on column B:B for all occurrences (in 'sTimeStamp Array' sheet) and background of the matching cell (in 'Task' sheet will be colored in red... In order to do that, I added a new record and modified an existing cell, for "Today" ("01-12"). Please do the same in order to obtain at least two results in column B:B.
Please confirm that this is what you wanted. If not, please better clarify the need...

Why does nested array crach excel when it reaches upper limit?

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

Extend vlookup to calculate cost of goods

I have sales report from e-shop and need to calculate cost of goods for each order line. Order line can look like one of these:
2x Lavazza Crema e Aroma 1kg - 1x Lavazza Dolce Caffe Crema 1kg
1x Lavazza Vending Aroma Top 1kg - 1x Arcaffe Roma 1Kg - 1x Kimbo - 100% Arabica Top Flavour
So, what I need Excel to do is to take each product, find its cost with vlookup function from another sheet and then multiply it with amount ordered. The issue is that nr of products ordered can vary from 1 to 10+.
I tried to calculate it with VBA, but the code is not working (I didnĀ“t use multiplying at the moment, I know)
Maybe it is possible to solve this problem with excel formulas?
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, strDelim)
Set lookup_range = Worksheets("Products").Range("B:E")
For i = LBound(larray) To UBound(larray)
skuarray = Split(larray(i), "x ")
skucost = Application.WorksheetFunction.VLookup(UBound(skuarray), lookup_range, 4, False)
cost = cost + skucost
Next i
GoodsCost = cost
End Function
Well, it seems like now the problem is solved. Of course, it works only if make an assumption that dashes(-) are not present in product descriptions. But it can be set up in product list. The other opportunity is to use another delimeter (for example "/"). We can use Ctrl+F to find all combinations like "x -" and replace them with "x /")
Function GoodsCost(str)
Dim answer As Double
Set Products = Worksheets("Products").Range("B:E")
larray = Split(str, " - ")
For i = LBound(larray) To UBound(larray)
sku = Split(larray(i), "x ")
Price = Application.WorksheetFunction.VLookup(sku(1), Products, 4, False) * sku(0)
answer = answer + Price
Next i
GoodsCost = answer
End Function
Below you find a UDF (User Defined Function) which you can use in your worksheet. After installing it in a standard code module (VBE names these like "Module1") you can call it from the worksheet like =CostOfGoods($A2) where A2 is the cell containing and order line as you have described.
Option Explicit
Function CostOfGoods(Cell As Range) As Single
' 15 Jan 2018
Const Delim As String = " - "
Dim Fun As Single ' function return value
Dim Sale As Variant
Dim Sp() As String
Dim i As Long
Dim PriceList As Range
Dim Qty As Single, Price As Single
Dim n As Integer
Sale = Trim(Cell.Value)
If Len(Sale) Then
Sp = Split(Sale, Delim)
Do While i <= UBound(Sp)
If InStr(Sp(i), "x ") = 0 Then
If Not ConcatSale(Sp, i, Delim) Then Exit Do
End If
i = i + 1
Loop
With Worksheets("Products")
i = .Cells(.Rows.Count, "B").End(xlUp).Row
' price list starts in row 2 (change as required)
Set PriceList = Range(.Cells(2, "B"), .Cells(i, "E"))
End With
For i = 0 To UBound(Sp)
Qty = Val(Sp(i))
n = InStr(Sp(i), " ")
Sp(i) = Trim(Mid(Sp(i), n))
On Error Resume Next
Price = Application.VLookup(Sp(i), PriceList, 4, False)
If Err Then
MsgBox "I couldn't find the price for" & vbCr & _
Sp(i) & "." & vbCr & _
"The total cost calculated excludes this item.", _
vbInformation, "Price not found"
Price = 0
End If
Fun = Fun + (Qty * Price)
Next i
End If
CostOfGoods = Fun
End Function
Private Function ConcatSale(Sale() As String, _
i As Long, _
Delim As String) As Boolean
' 15 Jan 2018
Dim Fun As Boolean ' function return value
Dim x As Long, f As Long
x = UBound(Sale)
If (i > 0) And (i <= x) Then
i = i - 1
Sale(i) = Sale(i) & Delim & Sale(i + 1)
For f = i + 1 To x - 1
Sale(f) = Sale(f + 1)
Next f
Fun = True
End If
If Fun Then ReDim Preserve Sale(x - 1)
ConcatSale = Fun
End Function
I have tested this and it works with dashes in product description:
Function GoodsCost(str, Optional strDelim As String = " ")
larray = Split(str, " ")
'split the cell contents by space
Set lookup_range = Worksheets("Products").Range("B:E")
'set lookup range
For i = LBound(larray) To UBound(larray) 'loop through array
nextproduct:
LPosition = InStr(larray(i), "x") 'find multiplier "x" in string
If LPosition = Len(larray(i)) Then 'if the last character is x
If Product <> "" Then GoTo lookitup 'lookup product
Quantity = larray(i) 'get quantity
Else
Product = Product & " " & larray(i) 'concatenate array until we get a full product description to lookup with
End If
Next i
lookitup:
If Right(Product, 2) = " -" Then Product = Left(Product, Len(Product) - 2)
If Left(Product, 1) = " " Then Product = Right(Product, Len(Product) - 1)
'above trim the Product description to remove unwanted spaces or dashes
cost = Application.WorksheetFunction.VLookup(Product, lookup_range, 4, False)
Quantity = Replace(Quantity, "x", "")
GoodsCost = cost * Quantity
MsgBox Product & " # Cost: " & GoodsCost
Product = ""
If i < UBound(larray) Then GoTo nextproduct
End Function
I'd use Regular Expressions to solve this. First it finds in the string were the 'delimiters' are by replacing the - with ; detecting only - that are next to a number followed by an x (i.e. a multiplier so ignoring - in product names). It then splits each of these results into a quantity and the product (again using RegEx). It then finds the product in your data and returns the cost of goods. If there is an error, or the product isn't in your data it returns a #Value error to show that there is an issue.
Public Function GoodsCost(str As String) As Double
Dim lookup_range As Range, ProductMatch As Range
Dim v, Match
Dim qty As Long
Dim prod As String
Dim tmp() As String
On Error GoTo err
Set lookup_range = Worksheets("Products").Range("B:E")
With CreateObject("vbscript.regexp")
.Global = True
.ignorecase = True
.pattern = "(\s\-\s)(?=[0-9]+x)"
If .test(str) Then
tmp = Split(.Replace(str, ";"), ";")
Else
ReDim tmp(0)
tmp(0) = str
End If
.pattern = "(?:([0-9]+)x\s(.+))"
For Each v In tmp
If .test(v) Then
Set Match = .Execute(v)
qty = Match.Item(0).submatches.Item(0)
prod = Trim(Match.Item(0).submatches.Item(1))
Set ProductMatch = lookup_range.Columns(1).Find(prod)
If Not ProductMatch Is Nothing Then
GoodsCost = GoodsCost + (qty * ProductMatch.Offset(0, 3))
Else
GoodsCost = CVErr(xlErrValue)
End If
End If
Next v
End With
Exit Function
err:
GoodsCost = CVErr(xlErrValue)
End Function

excel vba formula determining highest value based on text

Hi currently i'm having a problem regarding the displaying of the most significant text among 4 rows in one column . What I have here is remarks of clients which is excellent,good,fair and bad ..and i would like to display the word excellent on a cell if it is present in that column , otherwise if good is the highest value present then it should display it ,if fair then fair or and lastly if bad then display bad
enter image description here
Hope this is not too late to answer your question. Try the following formula:
=INDEX({"Bad","Fair","Good","Excellent"},MATCH(1,(MATCH({"Bad","Fair","Good","Excellent"},B2:E2,0)),0))
See the image for reference:
It's not a formula, but the main trouble, as I see, is not to grade four known values you listed above, but to exclude empty and unknown values. Moreover, when such happened, user must be informed about it and make the right decision...
'''''''
Private Sub sb_Test_fp_Grade3()
Debug.Print fp_Grade3(Selection, 1, True)
End Sub
Public Function fp_Grade3(pRng As Range, _
Optional pUnkMod& = 0, _
Optional pEmpDen As Boolean = False) As String
' pUnkMod - Mode of UnKnown grades handling
' 0-Ignore; 1-Info only; 2-Deny
' pEmpDen - Deny or not empty values. If Deny, then empty treated as Unknown
' according pUnkMod setting
Const S_BAD As String = "BAD"
Const S_FAI As String = "FAIR"
Const S_GOO As String = "GOOD"
Const S_EXC As String = "EXCELLENT"
Const S_UNK As String = "UNK" ' UNKNOWN
Dim rCell As Range
Dim lVal&, lMax&, lUnk&
Dim sGrades$(0 To 4), sRet$, sVal$
sGrades(0) = S_UNK
sGrades(1) = S_BAD
sGrades(2) = S_FAI
sGrades(3) = S_GOO
sGrades(4) = S_EXC
lMax = 0
lUnk = 0
sRet = vbNullString
For Each rCell In pRng
sVal = rCell.Value
If (LenB(sVal) > 0 Or pEmpDen) Then
Select Case UCase(rCell.Value)
Case S_BAD: lVal = 1
Case S_FAI: lVal = 2
Case S_GOO: lVal = 3
Case S_EXC: lVal = 4
Case Else: lVal = 0
End Select
Select Case (lVal > 0)
Case True ' Known values
If (lVal > lMax) Then
lMax = lVal
If (lMax = 4) Then
If (pUnkMod = 0) Then Exit For
End If
End If
Case False ' UnKnown values
Select Case pUnkMod
Case 0 ' ignore them
' do nothing
Case 1 ' info about them
lUnk = lUnk + 1
Case Else ' 2 & any others - stop
lMax = 0
Exit For
End Select
End Select
End If
Next
If (lUnk > 0) Then sRet = " & " & lUnk & "x" & S_UNK
sRet = sGrades(lMax) & sRet
fp_Grade3 = sRet
End Function
'''

Resources