I want to set a string as a certain letter based on the value of a cell. The cell should only have the values, "P1", "P2", "P3", "P4". If the cell is "P1" then I want to set the string "products2" as "a", if its "P2" I want "products2" set as "b" ...
Here is the code, which will get the correct value for the cell, but wont use it to set the products2.
Dim Products As String
Dim Products2 As String
Products = wash.offset(1, 3).Value
If Products = P1 Then
Products2 = "a"
ElseIf Products = P2 Then
MsgBox "we got here"
Products2 = "b"
End If
MsgBox "products2 = " & Products2
Here is a version that will do what you want, and extend it to P3 etc. I had to set wash to some location to get the code to work. It assumes that the value in the cell you are accessing is of the form Pi where i is an integer. It gets the value of i, shifted down by 1, then obtains gets the letter in the alphabet shifted by i (so "a" for 0, "b" for 1, etc.)
Sub ProdString()
Dim Products As String
Dim Products2 As String
Dim i As Long
Dim wash as Range
Set wash = Range("A1")
Products = wash.Offset(1, 3).Value
Products = Mid(Trim(Products), 2) 'strip off the "P"
i = Val(Trim(Products)) - 1
Products2 = Chr(i + Asc("a"))
MsgBox "Products2 = " & Products2
End Sub
The way it exists right now, it is trying to compare products to a variable rather than a string
Dim Products As String
Dim Products2 As String
Products = cstr(trim(wash.offset(1, 3).Value))
If Products = "P1" Then
Products2 = "a"
ElseIf Products = "P2" Then
MsgBox "we got here"
Products2 = "b"
End If
MsgBox "products2 = " & Products2
A good way to extend it so it easily covers "P1" through "P4" would be to use a select statement as follows:
Products = CStr(Trim(wash.Offset(1, 3).value))
Select Case Products
Case "P1":
Products2 = "a"
Case "P2":
Products2 = "b"
Case "P3":
Products2 = "c"
Case "P4":
Products2 = "d"
End Select
MsgBox "products2 = " & Products2
It's a lot easier to scan while reading.
My attempt
Function StrOut(strIn As String)
StrOut = Chr(96 + CLng(Replace(strIn, "P", vbNullString)))
End Function
test
Sub TestDaCode()
Debug.Print StrOut("P1")
Debug.Print StrOut("P2")
End Sub
Related
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
How do I extract a list of cell references from a string search found under the 1st column using VBA? For example, from the image attached below, how do I return a list of cell references of the string "Apple" from the 1st row? Preferably the list of the cell references should be listed under the 2nd column.
Data
Thank you in advance.
try this:
Option Compare Text 'to remove case sensitivity
Sub test()
Dim S1$, S2$, Fruits As Range, x As Range
Set Fruits = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)
For Each x In Fruits
If x.Value2 = "Apple" Then
S1 = S1 & " " & x.Address(0, 0)
ElseIf x.Value2 = "Kiwi" Then
S2 = S2 & " " & x.Address(0, 0)
End If
Next
S1 = Mid(S1, 2, Len(S1)): S2 = Mid(S2, 2, Len(S2))
Range([B2], Cells(UBound(Split(S1)) + 2, "B")) = Application.Transpose(Split(S1))
Range([C2], Cells(UBound(Split(S2)) + 2, "C")) = Application.Transpose(Split(S2))
End Sub
test:
My translation code is not working as I wanted... It should do the Propercase only in the first word of the cell, but it is doing the propercase in all of the words in the cell.
Any ideas on how to make it translate and only use propercase on the first word in the activecell?
Here is the code:
Sub traducaobeta2()
Dim translate As Object 'scritping.Dictionary
Set translate = CreateObject("Scripting.Dictionary")
translate("cadeira") = "chair"
translate("cadeira,") = "chair"
translate("cadeiras") = "chairs"
translate("criado mudo") = "night stand"
translate("criado-mudo") = "night stand"
translate("mesa") = "table"
translate("mesas") = "tables"
translate("e") = "and"
' the list goes on...
Dim Words As Variant
Dim I As Integer
Words = Split(LCase(activecell.Value))
For I = LBound(Words) To UBound(Words)
If translate(Words(I)) <> "" Then Words(I) = translate(Words(I))
Next
activecell.Value = Join(Words)
For Each x In activecell
x.Value = Application.Proper(x.Value)
Next
activecell.Offset(0, 1).Select
End Sub
Just make the first letter a captial:
ActiveCell.value = UCase$(Left$(ActiveCell.value, 1)) & Right$(ActiveCell.value, Len(ActiveCell.value) - 1)
Could also use a With block to save typing:
With ActiveCell
.value = UCase$(Left$(.value, 1)) & Right$(.value, Len(.value) - 1)
End With
I have the following search code:
Private Sub Search_Click()
Dim Name As String
Dim f As Range
Dim r As Long
Dim ws As Worksheet
Dim s As Integer
Dim FirstAddress As String
Name = surname.Value
With ws
Set f = Range("A:A").Find(what:=Name, LookIn:=xlValues)
If Not f Is Nothing Then
With Me
firstname.Value = f.Offset(0, 1).Value
tod.Value = f.Offset(0, 2).Value
program.Value = f.Offset(0, 3).Value
email.Value = f.Offset(0, 4).Text
officenumber.Value = f.Offset(0, 6).Text
cellnumber.Value = f.Offset(0, 7).Text
if f.offset(0,5).value = "PACT" then PACT.value = True
I want to modify the if f.offset(0,5).value: If I have one single value in a cell then it's easy to pick that one cell, link it to the checkbox and have the checkbox checkmarked. The problem is I have multiple values in the cell.
The values in the column 6 (f.offset(0,5).values) have the names as the checkboxes eg., checkboxes.name & " " so... PACT OTTAWA VANCOUVER MONTREAL TORONTO
This is done through an add command.
So the column 6 can display PACT OTTAWA VANCOUVER or PACT TORONTO or TORONTO depending on which checkboxes are clicked to add in userform.
If I can read and link to the name of the checkboxes and checkmark the ones that are in column 6 then that would work.
if f.offset(0,5).value = "PACT" then PACT.value = True
If I do it this way, then I'll have way too many combinations that I have to figure it out using if statements. Is there a way to "read" column 6, match it to the names of checkbox and checkmark the checkboxes in the userform when I click the search button?
EDIT:
Private Sub Search_Click()
Dim Name As String
Dim f As Range
Dim r As Long
Dim ws As Worksheet
Dim s As Integer
Dim FirstAddress As String
Dim str() As String
Name = surname.Value
With ws
Set f = Range("A:A").Find(what:=Name, LookIn:=xlValues)
If Not f Is Nothing Then
With Me
firstname.Value = f.Offset(0, 1).Value
tod.Value = f.Offset(0, 2).Value
program.Value = f.Offset(0, 3).Value
email.Value = f.Offset(0, 4).Text
officenumber.Value = f.Offset(0, 6).Text
cellnumber.Value = f.Offset(0, 7).Text
str() = Split(inputstr, " ")
For i = 0 To UBound(str)
Select Case UCase(Trim(str(i)))
Case "PACT": PACT.Value = True
Case "PrinceRupert": PrinceRupert.Value = True
Case "Montreal": Montreal.Value = True
Case "TET": TET.Value = True
Case "WPM": WPM.Value = True
Case "TC": TC.Value = True
Case "US": US.Value = True
Case "Other": Other.Value = True
End Select
Next i
I've added the following code but nothing happens.
I've searched on msdn but I don't quite understand the str() = split(inputstr, " ") and for I = 0 Ubound (str). I'm assuming the trim function is if after trimming the values of column 6 and case is "PACT" then PACT.value = True?
EDIT2:
It seems the code doesn't catch the words other than PACT and I'm assuming it picks up PACT because it's the first one. I've tried manually inputting the column 6 values and see if any names get picked up but it doesn't. Is there a way to fix this?
Perhaps it's because when I trim the data in column 6, it's seen as PACTPrinceRupertTETWPMTCUSOther. Is that why it won't pick it up?
Just as Siddharth said, Using split() and looping through the resulting array...
Dim str() As String
str() = Split(inputstr, " ")
For i = 0 To UBound(str)
Select Case ucase(trim(str(i)))
Case "PACT": pact.Value = True
case ....:
End Select
Next i
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.