Macro modification

Closed
kaluputha Posts 5 Registration date Friday February 19, 2010 Status Member Last seen March 2, 2010 - Feb 19, 2010 at 09:49 AM
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 - Feb 21, 2010 at 09:31 AM
Hello,
dear friend in my document column "L" has some numbers & formulas.if any cell has formula base in that i need to inset rows below that formula cell & that formula need to spread on that new rows.i have 5 type of formulas.each formula has (1.5).that part is common. it 's like this...

(01.)ex- L1 cell =150*1.5+50*1.5 ,need to inset one row below this cell & after running the macro it should change like this..
L1 cell =150*1.5
L2 cell =50*1.5

(02.)ex- L1 cell =150*2*1.5 ,need to inset one row below this cell & after running the macro it should change like this..
L1 cell =150*1.5
L2 cell =150*1.5

(03.)ex- L1 cell =150*2*1.5+50*1.5 ,need to inset two rows below this cell & after running the macro it should change like this..
L1 cell =150*1.5
L2 cell =150*1.5
L3 cell =50*1.5

(04.)ex- L1 cell =150*2*1.5+130*3*1.5 ,need to inset four rows below this cell & after running the macro it should change like this..
L1 cell =150*1.5
L2 cell =150*1.5
L3 cell =130*1.5
L4 cell =130*1.5
L5 cell =130*1.5

(05.)ex- L1 cell =150*2*1.5+130*3*1.5+20*1.5 ,need to inset five rows below this cell & after running the macro it should change like this..
L1 cell =150*1.5
L2 cell =150*1.5
L3 cell =130*1.5
L4 cell =130*1.5
L5 cell =130*1.5
L6 cell =20*1.5

for above work i have got this macro.

Code:

Sub main()
Dim LastRow As Integer ' The last row in column L
Dim i As Integer, j As Integer
Dim Part1 As String, Part2 As String, Part3 As String ' The parts of new formulas
Dim Repeater1 As Integer, Repeater2 As Integer, Repeater3 As Integer ' How many times we should repeat a new formula?

LastRow = Columns("L").SpecialCells(xlCellTypeLastCell).Row


For i = LastRow To 1 Step -1
'Is there a formula in the cell?
If (Has_a_formula(Cells(i, "L"))) Then
' Yes, the cell has a formula.
Call Translate(Cells(i, "L").Formula, Part1, Repeater1, Part2, Repeater2, Part3, Repeater3)

For j = Repeater1 + Repeater2 + Repeater3 To 2 Step -1
Rows(i).Insert Shift:=xlDown
Next j

j = i
Call InsertRows(j, Part1, Repeater1)
Call InsertRows(j, Part2, Repeater2)
Call InsertRows(j, Part3, Repeater3)
Else
' No, the cell has not a formula.
DoEvents
End If
Next i
MsgBox ("Done.")
End Sub

Private Function Has_a_formula(r As Range) As Boolean
Has_a_formula = (Left(r.Formula, 1) = "=")
End Function

Private Sub Translate(OldFormula As String, _
Part1 As String, Repeater1 As Integer, _
Part2 As String, Repeater2 As Integer, _
Part3 As String, Repeater3 As Integer)
Dim tmpFormula As String, i As Integer, tmpStr As String

tmpFormula = Mid(OldFormula, 2) ' Remove "="
Call Select_a_part_of_a_formula(tmpFormula, Part1, Repeater1)
Call Select_a_part_of_a_formula(tmpFormula, Part2, Repeater2)
Call Select_a_part_of_a_formula(tmpFormula, Part3, Repeater3)
End Sub

Private Sub Select_a_part_of_a_formula(Formula As String, Part As String, Repeater As Integer)
Dim i As Integer, j As Integer

Part = "": Repeater = 0
i = InStr(Formula, "*1.5")
If (i > 0) Then
If (InStr(Left(Formula, i - 1), "*") > 0) Then
j = InStr(Left(Formula, i - 1), "*")
Repeater = Mid(Formula, j + 1, i - j - 1)
Part = "=" & Left(Formula, j - 1) & "*1.5"
Else
Repeater = 1
Part = "=" & Formula
End If
End If

i = InStr(Formula, "+")
If (i > 0) Then
Formula = Mid(Formula, i + 1)
Else
Formula = ""
End If
End Sub

Private Sub InsertRows(Counter As Integer, Formula As String, Repeater As Integer)
Dim i As Integer

If (Formula <> "" And Repeater > 0) Then
For i = 1 To Repeater
Cells(Counter + i - 1, "L").Formula = Formula
Next i
End If
Counter = Counter + Repeater
End Sub

this is the my questions.
(01.)
if formula like this =150*1.5+25*1.5 then after running this macro it should like this.first row =150*1.5,inset new row below that cell & need on that cell =25*1.5.but this macro not doing it correctly.it's giving
=150*1.5+25*1.5
=25*1.5


(02.)
other all formulas this macro make correct.but new rows inserting not correct.i need to insert new rows below the original formula cell,but this macro inserting above the cell.

pls any body can make change in this macro.it's very big help for me.thanks.

3 replies

rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 768
Feb 19, 2010 at 10:03 AM
Could you put the file at some share site
https://authentification.site
0
kaluputha Posts 5 Registration date Friday February 19, 2010 Status Member Last seen March 2, 2010
Feb 20, 2010 at 01:38 AM
dear friends i have got the answer for second question..now i need only first question answer.pls help me....
https://authentification.site/files/21030298/test.xls
0
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 768
Feb 20, 2010 at 10:43 AM
I am not too sure about your logic in Select_a_part_of_a_formula
How ever the issue is because of this

Call Select_a_part_of_a_formula(tmpFormula, Part1, Repeater1)
Part 1 is equal to the formula. You are doing it in the code. See the boldline

If (i > 0) Then
If (InStr(Left(Formula, i - 1), "*") > 0) Then
j = InStr(Left(Formula, i - 1), "*")
Repeater = Mid(Formula, j + 1, i - j - 1)
Part = "=" & Left(Formula, j - 1) & "*1.5"
Else
Repeater = 1
Part = "=" & Formula
End If
End If

I dont get all your reasoning. But if "+" in the formula indicates various sub formulas that you want then why not do this

change this
Private Sub Translate(OldFormula As String, _
Part1 As String, Repeater1 As Integer, _
Part2 As String, Repeater2 As Integer, _
Part3 As String, Repeater3 As Integer)
Dim tmpFormula As String, i As Integer, tmpStr As String

tmpFormula = Mid(OldFormula, 2) ' Remove "="
Call Select_a_part_of_a_formula(tmpFormula, Part1, Repeater1)
Call Select_a_part_of_a_formula(tmpFormula, Part2, Repeater2)
Call Select_a_part_of_a_formula(tmpFormula, Part3, Repeater3)
End Sub

to

Private Sub Translate(OldFormula As String, _
Part1 As String, Repeater1 As Integer, _
Part2 As String, Repeater2 As Integer, _
Part3 As String, Repeater3 As Integer)
Dim tmpFormula As String, i As Integer, tmpStr As String

tmpFormula = Mid(OldFormula, 2) ' Remove "="
'Call Select_a_part_of_a_formula(tmpFormula, Part1, Repeater1)
'Call Select_a_part_of_a_formula(tmpFormula, Part2, Repeater2)
'Call Select_a_part_of_a_formula(tmpFormula, Part3, Repeater3)


subformula = Split(tmpFormula, "+")

Part1 = "=" & subformula(0)

If (UBound(subformula) = 1) Then

Repeater1 = 1
Part2 = "=" & subformula(1)
End If

If (UBound(subformula) = 2) Then
Repeater2 = 1
Part3 = "=" & subformula(2)

End If


End Sub

Of course since i was unable to follow your logic of breaking formula (when, why where etc), the above function may need to be tweaked a bit
0
kaluputha Posts 5 Registration date Friday February 19, 2010 Status Member Last seen March 2, 2010
Feb 21, 2010 at 09:22 AM
if u can make your own macro to do my work.thanks for your reply.....
0
rizvisa1 Posts 4479 Registration date Thursday January 28, 2010 Status Contributor Last seen May 5, 2022 768
Feb 21, 2010 at 09:31 AM
sorry I did not understand what you meant above " If u can make your own macro to do my work."
0