Extracting Number from various cell and added them and multiply with a factor

Hi all,

I am facing a problem in trying to extract a number for variouse cells (within the same row, one at a time) and to multiply them with number.

The following table can be seen in the attached file along with the macro:

Sub test()

Application.ScreenUpdating = False

Dim lr1 As Long

lr1 = Range("A" & Rows.Count).End(xlUp).Row


j = 1
sum2 = 0
sum1 = 0

stcol = 9
ltcol = 11

const1 = 1

For i = 3 To lr1
    Do While j <= 1 + 3
        If Cells(i, j) <> "" Then
            sum1 = 0
            counter = stcol
            Do While counter <= ltcol
                ltstr = Len(Cells(i, counter))
                If ltstr > 0 Then
                    If const1 = j Then
                        For w1 = 1 To ltstr
                            If Mid(Cells(i, counter), w, 1) = Left(Cells(2, j), 1) Then
                                psac1 = w1 'Position of Character in Question
                                Exit For
                            End If
                        Next w1
                        
                            If psac1 - 1 = 0 Then
                                num1 = 1
                            Else
                                num1 = Mid(Cells(i, counter), 1, (w1 - 1))
                            End If
                            
                        sum1 = sum1 + num1
                    Else
                        For w2 = 1 To ltstr
                            If Mid(Cells(i, counter), w2, 1) = Left(Cells(2, j), 1) Then
                                psac1 = w1 'Position of Character in Question
                                Exit For
                            End If
                        Next w2
                        For w1 = 1 To ltstr
                            If Mid(Cells(i, counter), w2, 1) = Left(Cells(2, j - 1), 1) Then
                                psac2 = w2 'Position of Character in Question
                                Exit For
                            End If
                        Next w1
                        
                            If w2 - w1 = 1 Then
                                num1 = 1
                            Else
                                num1 = Mid(Cells(i, counter), w1 + 1, (w2 - w1))
                            End If
                            
                        sum1 = sum1 + num1
                    End If
                End If
                counter = counter + 1
            Loop
        sum2 = sum2 + (sum1 * Cells(i, j + 12))
        Cells(i, 13) = sum2
        End If
        j = j + 1
    Loop
Next i

Application.ScreenUpdating = True
End Sub

Column L contains the manual calculation that I made as reference to check whether the code works or not.

For example Cell L5 basically is 120 times 0.1. And Cell L9 is:
(120 x 0.2) + (120 x 0.2) + (120 x 0.2) + (10 x 0.1) + (10 x 0.1) + (10 x 0.1) + 0.5 = 75.5

And the code above basically trying to copy the calculation above automatically.

It would be great if I could get some assistance to make my code works.

Thanks in advance

With UDF. Note that in row 12 your manual calculation is incorrect
Question in Excel Forum 090914.xlsm

I tried to add a little as shown below:

Sub test4()

For i = 3 To 5

Cells(i, 13) = CalcThis(Range(Cells(i, 9), Cells(i, 11)), Cells(i, 6), Cells(i, 7), Cells(i, 8), Cells(i, 9))

Next i

End Sub
Public Function CalcThat#(inputDiap As Range, insp As Range, lube As Range, tigh As Range, repl As Range)
    Dim fStr$, fStrOut$
    
    For Each iCell In inputDiap
        fStr = IIf(InStr(iCell.Text, "I") > 0, Replace(UCase(iCell.Text), "I", "*" & insp.Text & "+"), UCase(iCell.Text))
      
        fStr = IIf(InStr(fStr, "L") > 0, Replace(fStr, "L", "*" & lube.Text & "+"), fStr)
        
        fStr = IIf(InStr(fStr, "T") > 0, Replace(fStr, "T", "*" & tigh.Text & "+"), fStr)
        
        fStr = IIf(InStr(fStr, "R") > 0, Replace(fStr, "R", "*" & repl.Text & "+"), fStr)
        
        fStrOut = fStrOut & fStr
    Next
    
    fStrOut = Replace(fStrOut, "+*", "+1*")
    Do While Right(fStrOut, 1) = "+"
        fStrOut = Left(fStrOut, Len(fStrOut) - 1)
    Loop
    
    Do While Left(fStrOut, 1) = "+" Or Left(fStrOut, 1) = "*"
        fStrOut = Mid(fStrOut, 2)
    Loop
    
    CalcThat = Evaluate(Replace(fStrOut, ",", "."))
End Function

But I got Run-time error '13': Type mismatch on line : CalcThat = Evaluate(Replace(fStrOut, ",","."))

double post..

Sub

Public Sub CalcThis2()
    Dim inputDiap As Range, insp As Range, lube As Range, tigh As Range, repl As Range
    Dim fStr$, fStrOut$, lRow&
    
    With ActiveSheet
        lRow = .[A1].SpecialCells(xlLastCell).Row
        
        For i = 3 To lRow
            fStrOut = ""
            For Each iCell In .Cells(i, "I").Resize(1, 3)
                fStr = IIf(InStr(iCell.Text, "I") > 0, Replace(UCase(iCell.Text), "I", "*" & .Cells(i, "E").Text & "+"), UCase(iCell.Text))
        
                fStr = IIf(InStr(fStr, "L") > 0, Replace(fStr, "L", "*" & .Cells(i, "F").Text & "+"), fStr)
        
                fStr = IIf(InStr(fStr, "T") > 0, Replace(fStr, "T", "*" & .Cells(i, "G").Text & "+"), fStr)
        
                fStr = IIf(InStr(fStr, "R") > 0, Replace(fStr, "R", "*" & .Cells(i, "H").Text & "+"), fStr)
        
                fStrOut = fStrOut & fStr
            Next
            
            fStrOut = Replace(fStrOut, "+*", "+1*")
            Do While Right(fStrOut, 1) = "+"
                fStrOut = Left(fStrOut, Len(fStrOut) - 1)
            Loop
        
            Do While Left(fStrOut, 1) = "+" Or Left(fStrOut, 1) = "*"
                fStrOut = Mid(fStrOut, 2)
            Loop
            
            .Cells(i, "O") = Evaluate(Replace(fStrOut, ",", "."))   'Evaluate(fStrOut)
        Next i
    End With
End Sub

For example it will not always be 120I10L in cell I9, it can becomes 200I20L or even 100I20L2R, then will it be a problem?

No, it won`t be a problem

But I got Run-time error '13': Type mismatch on line : CalcThat = Evaluate(Replace(fStrOut, ",","."))

Then try to use

CalcThat = Evaluate(fStrOut)

Hi Lancer,

It works great with your CalcThis2, I need to understand your concept so that I can utilize it when facing similar problem.

I will consider this thread as solved, and it would be great if you can explain a little bit of your approch in language..

Thank you very much..

The code works so:
e.g. we have

INSP	LUBE	TIGH	REPL	Y1	Y2	Y3
0,2	0,1	0,3	5	120I10L	40T10L	50IR

We reading each cell value and replacing chars "I","L","T" & "R" to their values from columns "INSP", "LUBE", "TIGH" & "REPL" respectively. Of course we don`t forget, that we have to summarize this values, so we add "+" between addendums. That is why we get:
1) "120I10L" = "120*0,2+10*0,1"
2) "40T10L" = "40*0,3+10*0,1"
3) "50IR" = "50*0,2+*5"

Then we concat all 3 string with "+" between them "120*0,2+10*0,1+40*0,3+10*0,1+50*0,2+*5"

As you see we got unecpected operation at the end of the string: "+*". So we replace such thing to operation of multiply by 1. "+*5" = "+1*5"

Then it remains only to convert string representing formula to its value. This does EVALUATE function

you fStrOut string is empty. And leng-1 = -1. mid function don`t accept negative argument.
Why did you comment rows in "For Each iCell In .Cells(i, "I").Resize(1, 3)" block?
If there is no others chars in cells text, then code will miss this parts

Originally Posted by lancer102rus

you fStrOut string is empty. And leng-1 = -1. mid function don`t accept negative argument.
Why did you comment rows in "For Each iCell In .Cells(i, "I").Resize(1, 3)" block?
If there is no others chars in cells text, then code will miss this parts

Because I want to focus on the number of activity of column LUBE, for example the table now can becomes:

INSP	LUBE	TIGH	REPL	Y1	Y2	Y3	INSP	LUBE	TIGH
0.2	0.1	0.3	5	120I10L	40T10L	50IR	170	20	40

Oh! Now I anderstood. You need again sub? Not UDF?

Originally Posted by lancer102rus

Oh! Now I anderstood. You need again sub? Not UDF?

I need in a sub

OK. check this
Question in Excel Forum 090914.xlsm

Originally Posted by lancer102rus

OK. check this
Attachment 344118

Hi,

It seems that if the column in I & J having L L or R R (both column single), then returning error value of #VALUE

Originally Posted by a_driga

Hi,

It seems that if the column in I & J having L L or R R (both column single), then returning error value of #VALUE

Attach file with example, pls.

Hi Lancer,

Many thanks for your solution,

Since normally, I need the constant & parameter to be a little bit flexible, there are several things to ask:

Public Sub CalcThis3()
    Dim inputDiap As Range, insp As Range, lube As Range, tigh As Range, repl As Range
    Dim fStr$, fStrOut$, lRow&
    
    With ActiveSheet
        lRow = .[A1].SpecialCells(xlLastCell).Row
        
        For i = 3 To lRow
            fStr = ""
            For Each iCell In .Cells(i, "I").Resize(1, 3)
                fStr = fStr & iCell.Text
            Next
            
            .Cells(i, "P") = Evaluate(rplc(fStr, "I"))
            .Cells(i, "Q") = Evaluate(rplc(fStr, "L"))
            .Cells(i, "R") = Evaluate(rplc(fStr, "T"))
            .Cells(i, "S") = Evaluate(rplc(fStr, "R"))
        Next i
    End With
End Sub

1. Can I omit With & End With? I did try to use the following to find lRow = range("A" & rows.count).end(xlup).row and it did not work.
2. Can I change the column signature "P", "Q" into constant, lets say cells(i, 16) for "P"
3. Can I change I into let's say left(range("P2"), 1), where cell P2 contains INSP?

Honestly, I am still kinda new with your approach since I never used such approach before.

Thanks in advance.

1. Can I omit With & End With? I did try to use the following to find lRow = range("A" & rows.count).end(xlup).row and it did not work.

You can, but don`t forget to use full path for the cell:

lRow = ActiveSheet.Range("A" & ActiveSheet.Rows.Count).end(xlUp).row

You must remember, that there is no guarantee that you will get real last row in such way. In 3 - 8 rows cells are empty in column "A", so it could happen that last rows of the table also can be empty, and macro won`t see them.

2. Can I change the column signature "P", "Q" into constant, lets say cells(i, 16) for "P"

Yes you can, because cells(i, 16) = cells(i, "P") (as well as cells(i,1)=cells(i,"A"), cells(i,3)=cells(i,"C") etc.). For me the second way is more anderstandable because you don`t use R1C1 reference style.

3. Can I change I into let's say left(range("P2"), 1), where cell P2 contains INSP?

If you use only this 4 chars (I, L, T & R) you can. Other chars code won`t see, because I put them ito constant string in function rplc:

Function rplc$(inputStr$, lookCh$)
    Const ptrStr$ = "ILTR"
    rplc = inputStr
    For i = 1 To 4
    
        rplc = IIf(Mid(ptrStr, i, 1) = lookCh, Replace(rplc, Mid(ptrStr, i, 1), "*1+"), Replace(rplc, Mid(ptrStr, i, 1), "*0+"))
    Next i
    
    Do While Right(rplc, 1) = "+"
        rplc = Left(rplc, Len(rplc) - 1)
    Loop
    
    rplc = Replace(rplc, "+*", "+1*")
    If rplc = "*1" Then
        rplc = "1"
    ElseIf rplc = "*0" Then
        rplc = "0"
    End If
End Function

Here is the attachment

I see. Didn`t notice some situations...
Question in Excel Forum 090914.xlsm

Originally Posted by lancer102rus

I see. Didn`t notice some situations...

I will try on this, and by the way is there a meaning in giving dollar sign for example in fStr$?

fStr$ = fStr as String
i& = i as Double
etc.

Though I am still trying to grasp your solution but it works perfectly..

And with a small modification, I can use it..

Thanks Lancer!

Hi Lancer,

I have another problem with the speed. I am trying to make calculation along the column instead of row like previously.

How come the required time to do calculation nearly 1 hour? Is there any solution to make the process faster?

File is attached with the real problem I am facing..

Thanks

10 seconds
Question in Excel Forum 120914.xlsm

Originally Posted by lancer102rus

10 seconds

Did you alter the code? Or did you just run it and got 10 seconds?
However, the answer in row 678 is not right using the code supplied with the file you attached.
The answer in row 678 should be the sum of multiplication between the number of activity & man-hour.

I think, it is because you commented line 28. 29 and 39.

Didn`t anderstand your previous message. Sorry. Now it works much faster
Question in Excel Forum 090914.xlsm