# Combine Calculate in a cells with several calculate in that cell and after that another calculate based on that cell

#### Unexpc

##### Active Member
Hi guys
i have main problem and if you solve this, solve my main problem and helped me to calculate any of numbers that i do this in many hours
this is my problem
i have this worksheet that you see before, in first i said that belong to text, but that have information for main calculate, better say
in one cell i write information with this format : Give (+ Value) or Receive (-Value) ,G Or M, Text, Number, Percent or Thousands or Hundred (if Give and G and Percent: Percent that multiply to Number that written before this (if i not write anything in this part, multiply with 1), if Give and G and Thousands: Thousand multiply with number, if Receive and G and Percent: Percent multiply with number, if Receive and G and Hundred: Hundred multiply with number and then divide 750, for Give M that all this value sum and fill in specific columns that i say in below but for Receive M, if write MM after that calculate: Number multiply MM and divide 4.3318 if not write like Give M Calculate)
This fill in Column A
Columns B:C fill with Text without calculate
but in Column D
This fills with SUM of Gives and Back (+ Value) Calculates from G
in Column E
fills with SUM of Receive (- Value) Calculates from G
in Column F
fills with SUM of Gives (+ Value) Calculates from M
in Column G
fills with SUM of Receive (-Value) Calculates from M
and a point, i can't split information that belong one cell, because all of the info about a day and should write all info in one cell

#### Attachments

• image_2021-07-16_183906.png
20.9 KB · Views: 23

#### Unexpc

##### Active Member
I think you don't need alphabet at the first of cases.
Try this for numbering Correctly:
VBA Code:
``````Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, J As Long, Lr1 As Long, Lr2 As Long, Cr As Long, CrR As String, Lr3 As Long, Lr4 As Long, K As Long
Dim A As Double, B As Double, C As Double, D As Double, E As Double, F As Double, G As Double, H As Double
Dim I2 As String, J2 As Double, K2 As String, L As Double, M As Long, N As Long, O As Long, Lnum As Long, M1 As Long
Dim T As String, P As Long, R As Long, S1 As Double, S2 As Double, W As Long, X As Long, Y As Long, M2 As Long
Dim ii As Long, bb As Long, cc As String, nn As Long, ee As Double, gg As Double, Lst As String, pp As Long, rr As Long
Dim Q As Double, S As Double, U As Double, Z As Double, S3 As Double, ff As Long, qq As Long, ss As Long, tt As Long
Lr1 = Sheets("Dashboard").Range("I" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("Dashboard").Range("N" & Rows.Count).End(xlUp).Row
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row

If Intersect(Target, Range("A1:A" & Lr3)) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.FindFormat.Clear
Application.FindFormat.Interior.Color = 14277081
M2 = Sheets("Work").Range("A1:A" & Rows.Count).Find("", , , , , xlPrevious, , , True).Row
'    Rows(M2 + 1 & ":" & Rows.Count).Hidden = False
If Target.Interior.Color = 14277081 Then
If Target.Value <> "" Then
If IsNumeric(Target.Value) And Target.Value > 0 Then
Sheets("Work").Rows(M2 + 1).Resize(Target.Value).Hidden = False
Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
End If
Target.Value = ""
End If
ElseIf Target.Interior.Color = 16777215 Then
T = Replace(Range("A" & Target.Row).Value, vbLf, "")
X = Len(T) - Len(Replace(T, "&", "")) + 1
For M = 1 To X
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
If Mid(T, bb - 1, 1) = M Then GoTo NextF
Debug.Print Mid(T, bb - 1, 1)
T = Left(T, bb - 1) & M & Right(T, Len(T) - bb + 1)
NextF:
Next M
Debug.Print T
For M = X To 1 Step -1
If M < X Then
Y = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(T, "&", Chr(1), M))
Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
Else
Y = Len(T)
End If
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
cc = Trim(Mid(T, bb, 1))
O = bb + 1
Lst = Mid(T, O, Y - O + 1)
On Error Resume Next
ff = Application.WorksheetFunction.Find("@", Lst)
pp = Application.WorksheetFunction.Find("#", Lst)
qq = Application.WorksheetFunction.Find("\$", Lst)
ss = Application.WorksheetFunction.Find("%", Lst)
tt = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Lst, "\$", Chr(1), 2))
On Error GoTo 0
If pp > 0 Then cc = cc & "#"
If qq > 0 Then cc = cc & "\$"
If tt > 0 Then cc = cc & "\$"
If ff > 0 Then cc = cc & "@"
If ss > 0 Then cc = cc & "%"
Debug.Print T
Lst = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Lst, 9, 0), 8, 0), 7, 0), 6, 0), 5, 0), 4, 0), 3, 0), 2, 0), 1, 0)
rr = Application.WorksheetFunction.Find(0, Lst)

Select Case cc
Case "-#\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
Z = Z + Round(S1 + (S1 * S2 / S3 * 4.3318), 2) * -1
Case "+#\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
U = U + Round(S1 + (S1 * S2 / S3 * 4.3318), 2)
Case "+#%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
A = A + Round(S1 * (1 + S2 / 100), 2)
Case "+#\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
B = B + S1 * S2
J2 = J2 + S1
Case "-#%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
C = C + Round(S1 * (1 + S2 / 100) * -1, 2)
Case "-#\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
D = D + S1 * S2 * -1
L = L + S1 * -1
Case "+#@"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
On Error Resume Next
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ff - rr))
If S2 = 0 Then
ss = InStr(rr + 2, Lst, " ")
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
End If
ee = ee + Round((S1 * S2) / 750, 2)
Case "-#@"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
On Error Resume Next
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ff - rr))
If S2 = 0 Then
ss = InStr(rr + 2, Lst, " ")
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
End If
gg = gg + Round(-(S1 * S2) / 750, 2)
Case "+\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
E = E + S1 * 1
Case "+\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
F = F + Round((S1 / S2) * 4.3318, 2)
Case "-\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
G = G + S1 * -1
Case "-\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
H = H + Round((S1 / S2) * -4.3318, 2)
Case "+#"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
Q = Q + Round(S1, 2)
Case "-#"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
S = S + Round(S1, 2) * -1
Case "-#\$%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
rr = InStr(ss + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
Z = Z + Round(S1 + (S1 * S2 / 100), 2) * -1
D = D + S1 * S3 * -1
Case "+#\$%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
rr = InStr(ss + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
U = U + Round(S1 + (S1 * S2 / 100), 2)
B = B + S1 * S3
End Select
ff = 0
pp = 0
qq = 0
rr = 0
tt = 0
ss = 0
S1 = 0
S2 = 0
S3 = 0
Next M

'' Notes : Here I add calculated results to cells
Range("D" & Target.Row).Formula = "=Round(" & A & "+" & J2 & "+" & F & "+" & ee & "+" & Q & "+" & U & ", 2)"
Range("E" & Target.Row).Formula = "=Round(" & C & "+" & L & "+" & H & "+" & gg & "+" & S & "+" & Z & ", 2)"
Range("F" & Target.Row).Formula = "=" & B & "+" & E
Range("G" & Target.Row).Formula = "=" & D & "+" & G
'' Note: Add again ALT+ENTER to the Text at the Cell

Range("A" & Target.Row).Value = Replace(T, "&", "&" & vbLf)

'MsgBox "A1 = " & A & vbCr & "B1 = " & J2 & " // " & "B2 = " & B & vbCr & "C1 = " & C & vbCr & "D1 = " & L _
& " // " & "D2 = " & D & vbCr & "E1 = " & E & vbCr & "F1 = " & F & vbCr & "G1 = " & G & vbCr & "H1 = " & _
H & vbCr & "Q1 = " & Q & vbCr & "S1 = " & S & vbCr & "U1 = " & U & vbCr & "Z1 = " & Z

End If
Application.FindFormat.Interior.Color = 14277081
For i = 3 To Lr1 - 1
M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i), Sheets("Work").Range("A1:A" & Lr3 + 100), 0) + 2
M = Sheets("Work").Range("A" & M1 & ":A" & Lr3 + 100).Find("", , , , , xlNext, , , True).Row - 1
Sheets("Dashboard").Range("J" & i).Formula = "=Work!B" & M
Sheets("Dashboard").Range("K" & i).Formula = "=SUM(Work!D" & M1 & ":E" & M & ")"
Sheets("Dashboard").Range("L" & i).Formula = "=SUM(Work!F" & M1 & ":G" & M & ")"
Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3 + 20), 0)
CrR = Range("A" & Cr).Address
Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("I" & i).Value
With Sheets("Dashboard").Range("I" & i)
.Font.Underline = xlUnderlineStyleNone
.Font.ColorIndex = xlColorIndexAutomatic
.Font.Name = "Microsoft Parsi"
.Font.Size = 14
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next i
'  M2 = Sheets("Work").Range("A" & Lr3 + 2 & ":A" & Rows.Count - 100).Find("", , , , , xlPrevious, , , True).Row
'    Rows(M2 + 1 & ":" & Rows.Count).Hidden = True
Application.FindFormat.Clear
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub``````
it does correctly! Thanks...

### Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

You're Welcome.

#### Unexpc

##### Active Member
another thing that make problem for work, i use insert sheet rows and delete sheet rows button in ribbon and with this code i not test it recently but i use them and make problem for code that didn't work and wrong alignment (in edit cell) even i set it again, show this error:

#### Attachments

• Annotation 2021-11-05 231649.png
5.3 KB · Views: 5
• Annotation 2021-11-05 231655.png
36.2 KB · Views: 5

##### Well-known Member
this problem occurs because it doesn't find number at cell. try this to ignore cell when insert or delete row:
VBA Code:
``````Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, J As Long, Lr1 As Long, Lr2 As Long, Cr As Long, CrR As String, Lr3 As Long, Lr4 As Long, K As Long
Dim A As Double, B As Double, C As Double, D As Double, E As Double, F As Double, G As Double, H As Double
Dim I2 As String, J2 As Double, K2 As String, L As Double, M As Long, N As Long, O As Long, Lnum As Long, M1 As Long
Dim T As String, P As Long, R As Long, S1 As Double, S2 As Double, W As Long, X As Long, Y As Long, M2 As Long
Dim ii As Long, bb As Long, cc As String, nn As Long, ee As Double, gg As Double, Lst As String, pp As Long, rr As Long
Dim Q As Double, S As Double, U As Double, Z As Double, S3 As Double, ff As Long, qq As Long, ss As Long, tt As Long
Lr1 = Sheets("Dashboard").Range("I" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("Dashboard").Range("N" & Rows.Count).End(xlUp).Row
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row

If Intersect(Target, Range("A1:A" & Lr3)) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.FindFormat.Clear
Application.FindFormat.Interior.Color = 14277081
M2 = Sheets("Work").Range("A1:A" & Rows.Count).Find("", , , , , xlPrevious, , , True).Row
'    Rows(M2 + 1 & ":" & Rows.Count).Hidden = False
If Target.Interior.Color = 14277081 Then
If Target.Value <> "" Then
If IsNumeric(Target.Value) And Target.Value > 0 Then
Sheets("Work").Rows(M2 + 1).Resize(Target.Value).Hidden = False
Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
End If
Target.Value = ""
End If
ElseIf Target.Interior.Color = 16777215 Then
T = Replace(Range("A" & Target.Row).Value, vbLf, "")
X = Len(T) - Len(Replace(T, "&", "")) + 1
For M = 1 To X
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
If Mid(T, bb - 1, 1) = M Then GoTo NextF
Debug.Print Mid(T, bb - 1, 1)
T = Left(T, bb - 1) & M & Right(T, Len(T) - bb + 1)
NextF:
Next M
Debug.Print T
For M = X To 1 Step -1
If M < X Then
Y = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(T, "&", Chr(1), M))
Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
Else
Y = Len(T)
End If
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
cc = Trim(Mid(T, bb, 1))
O = bb + 1
Lst = Mid(T, O, Y - O + 1)
On Error Resume Next
ff = Application.WorksheetFunction.Find("@", Lst)
pp = Application.WorksheetFunction.Find("#", Lst)
qq = Application.WorksheetFunction.Find("\$", Lst)
ss = Application.WorksheetFunction.Find("%", Lst)
tt = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Lst, "\$", Chr(1), 2))
On Error GoTo 0
If pp > 0 Then cc = cc & "#"
If qq > 0 Then cc = cc & "\$"
If tt > 0 Then cc = cc & "\$"
If ff > 0 Then cc = cc & "@"
If ss > 0 Then cc = cc & "%"
Debug.Print T
Lst = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Lst, 9, 0), 8, 0), 7, 0), 6, 0), 5, 0), 4, 0), 3, 0), 2, 0), 1, 0)
On Error goto Resum9
rr = Application.WorksheetFunction.Find(0, Lst)

Select Case cc
Case "-#\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
Z = Z + Round(S1 + (S1 * S2 / S3 * 4.3318), 2) * -1
Case "+#\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
U = U + Round(S1 + (S1 * S2 / S3 * 4.3318), 2)
Case "+#%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
A = A + Round(S1 * (1 + S2 / 100), 2)
Case "+#\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
B = B + S1 * S2
J2 = J2 + S1
Case "-#%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
C = C + Round(S1 * (1 + S2 / 100) * -1, 2)
Case "-#\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
D = D + S1 * S2 * -1
L = L + S1 * -1
Case "+#@"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
On Error Resume Next
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ff - rr))
If S2 = 0 Then
ss = InStr(rr + 2, Lst, " ")
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
End If
ee = ee + Round((S1 * S2) / 750, 2)
Case "-#@"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
On Error Resume Next
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ff - rr))
If S2 = 0 Then
ss = InStr(rr + 2, Lst, " ")
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
End If
gg = gg + Round(-(S1 * S2) / 750, 2)
Case "+\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
E = E + S1 * 1
Case "+\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
F = F + Round((S1 / S2) * 4.3318, 2)
Case "-\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
G = G + S1 * -1
Case "-\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
H = H + Round((S1 / S2) * -4.3318, 2)
Case "+#"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
Q = Q + Round(S1, 2)
Case "-#"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
S = S + Round(S1, 2) * -1
Case "-#\$%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
rr = InStr(ss + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
Z = Z + Round(S1 + (S1 * S2 / 100), 2) * -1
D = D + S1 * S3 * -1
Case "+#\$%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
rr = InStr(ss + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
U = U + Round(S1 + (S1 * S2 / 100), 2)
B = B + S1 * S3
End Select
ff = 0
pp = 0
qq = 0
rr = 0
tt = 0
ss = 0
S1 = 0
S2 = 0
S3 = 0
Next M

'' Notes : Here I add calculated results to cells
Range("D" & Target.Row).Formula = "=Round(" & A & "+" & J2 & "+" & F & "+" & ee & "+" & Q & "+" & U & ", 2)"
Range("E" & Target.Row).Formula = "=Round(" & C & "+" & L & "+" & H & "+" & gg & "+" & S & "+" & Z & ", 2)"
Range("F" & Target.Row).Formula = "=" & B & "+" & E
Range("G" & Target.Row).Formula = "=" & D & "+" & G
'' Note: Add again ALT+ENTER to the Text at the Cell

Range("A" & Target.Row).Value = Replace(T, "&", "&" & vbLf)

'MsgBox "A1 = " & A & vbCr & "B1 = " & J2 & " // " & "B2 = " & B & vbCr & "C1 = " & C & vbCr & "D1 = " & L _
& " // " & "D2 = " & D & vbCr & "E1 = " & E & vbCr & "F1 = " & F & vbCr & "G1 = " & G & vbCr & "H1 = " & _
H & vbCr & "Q1 = " & Q & vbCr & "S1 = " & S & vbCr & "U1 = " & U & vbCr & "Z1 = " & Z

End If
Resum9:
Application.FindFormat.Interior.Color = 14277081
For i = 3 To Lr1 - 1
M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i), Sheets("Work").Range("A1:A" & Lr3 + 100), 0) + 2
M = Sheets("Work").Range("A" & M1 & ":A" & Lr3 + 100).Find("", , , , , xlNext, , , True).Row - 1
Sheets("Dashboard").Range("J" & i).Formula = "=Work!B" & M
Sheets("Dashboard").Range("K" & i).Formula = "=SUM(Work!D" & M1 & ":E" & M & ")"
Sheets("Dashboard").Range("L" & i).Formula = "=SUM(Work!F" & M1 & ":G" & M & ")"
Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3 + 20), 0)
CrR = Range("A" & Cr).Address
Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("I" & i).Value
With Sheets("Dashboard").Range("I" & i)
.Font.Underline = xlUnderlineStyleNone
.Font.ColorIndex = xlColorIndexAutomatic
.Font.Name = "Microsoft Parsi"
.Font.Size = 14
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next i
'  M2 = Sheets("Work").Range("A" & Lr3 + 2 & ":A" & Rows.Count - 100).Find("", , , , , xlPrevious, , , True).Row
'    Rows(M2 + 1 & ":" & Rows.Count).Hidden = True
Application.FindFormat.Clear
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub``````

#### Unexpc

##### Active Member
this problem occurs because it doesn't find number at cell. try this to ignore cell when insert or delete row:
VBA Code:
``````Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, J As Long, Lr1 As Long, Lr2 As Long, Cr As Long, CrR As String, Lr3 As Long, Lr4 As Long, K As Long
Dim A As Double, B As Double, C As Double, D As Double, E As Double, F As Double, G As Double, H As Double
Dim I2 As String, J2 As Double, K2 As String, L As Double, M As Long, N As Long, O As Long, Lnum As Long, M1 As Long
Dim T As String, P As Long, R As Long, S1 As Double, S2 As Double, W As Long, X As Long, Y As Long, M2 As Long
Dim ii As Long, bb As Long, cc As String, nn As Long, ee As Double, gg As Double, Lst As String, pp As Long, rr As Long
Dim Q As Double, S As Double, U As Double, Z As Double, S3 As Double, ff As Long, qq As Long, ss As Long, tt As Long
Lr1 = Sheets("Dashboard").Range("I" & Rows.Count).End(xlUp).Row
Lr2 = Sheets("Dashboard").Range("N" & Rows.Count).End(xlUp).Row
Lr3 = Sheets("Work").Range("A" & Rows.Count).End(xlUp).Row
Lr4 = Sheets("Paper").Range("A" & Rows.Count).End(xlUp).Row

If Intersect(Target, Range("A1:A" & Lr3)) Is Nothing Then Exit Sub
On Error Resume Next
Application.EnableEvents = False
Application.ScreenUpdating = False
Application.FindFormat.Clear
Application.FindFormat.Interior.Color = 14277081
M2 = Sheets("Work").Range("A1:A" & Rows.Count).Find("", , , , , xlPrevious, , , True).Row
'    Rows(M2 + 1 & ":" & Rows.Count).Hidden = False
If Target.Interior.Color = 14277081 Then
If Target.Value <> "" Then
If IsNumeric(Target.Value) And Target.Value > 0 Then
Sheets("Work").Rows(M2 + 1).Resize(Target.Value).Hidden = False
Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
End If
Target.Value = ""
End If
ElseIf Target.Interior.Color = 16777215 Then
T = Replace(Range("A" & Target.Row).Value, vbLf, "")
X = Len(T) - Len(Replace(T, "&", "")) + 1
For M = 1 To X
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
If Mid(T, bb - 1, 1) = M Then GoTo NextF
Debug.Print Mid(T, bb - 1, 1)
T = Left(T, bb - 1) & M & Right(T, Len(T) - bb + 1)
NextF:
Next M
Debug.Print T
For M = X To 1 Step -1
If M < X Then
Y = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(T, "&", Chr(1), M))
Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
Else
Y = Len(T)
End If
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
cc = Trim(Mid(T, bb, 1))
O = bb + 1
Lst = Mid(T, O, Y - O + 1)
On Error Resume Next
ff = Application.WorksheetFunction.Find("@", Lst)
pp = Application.WorksheetFunction.Find("#", Lst)
qq = Application.WorksheetFunction.Find("\$", Lst)
ss = Application.WorksheetFunction.Find("%", Lst)
tt = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Lst, "\$", Chr(1), 2))
On Error GoTo 0
If pp > 0 Then cc = cc & "#"
If qq > 0 Then cc = cc & "\$"
If tt > 0 Then cc = cc & "\$"
If ff > 0 Then cc = cc & "@"
If ss > 0 Then cc = cc & "%"
Debug.Print T
Lst = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Lst, 9, 0), 8, 0), 7, 0), 6, 0), 5, 0), 4, 0), 3, 0), 2, 0), 1, 0)
On Error goto Resum9
rr = Application.WorksheetFunction.Find(0, Lst)

Select Case cc
Case "-#\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
Z = Z + Round(S1 + (S1 * S2 / S3 * 4.3318), 2) * -1
Case "+#\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
U = U + Round(S1 + (S1 * S2 / S3 * 4.3318), 2)
Case "+#%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
A = A + Round(S1 * (1 + S2 / 100), 2)
Case "+#\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
B = B + S1 * S2
J2 = J2 + S1
Case "-#%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
C = C + Round(S1 * (1 + S2 / 100) * -1, 2)
Case "-#\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
D = D + S1 * S2 * -1
L = L + S1 * -1
Case "+#@"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
On Error Resume Next
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ff - rr))
If S2 = 0 Then
ss = InStr(rr + 2, Lst, " ")
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
End If
ee = ee + Round((S1 * S2) / 750, 2)
Case "-#@"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
On Error Resume Next
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ff - rr))
If S2 = 0 Then
ss = InStr(rr + 2, Lst, " ")
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
End If
gg = gg + Round(-(S1 * S2) / 750, 2)
Case "+\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
E = E + S1 * 1
Case "+\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
F = F + Round((S1 / S2) * 4.3318, 2)
Case "-\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
G = G + S1 * -1
Case "-\$\$"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
rr = InStr(qq + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, tt - rr))
H = H + Round((S1 / S2) * -4.3318, 2)
Case "+#"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
Q = Q + Round(S1, 2)
Case "-#"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
S = S + Round(S1, 2) * -1
Case "-#\$%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
rr = InStr(ss + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
Z = Z + Round(S1 + (S1 * S2 / 100), 2) * -1
D = D + S1 * S3 * -1
Case "+#\$%"
S1 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, pp - rr))
rr = InStr(pp + 1, Lst, 0)
S2 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, ss - rr))
rr = InStr(ss + 1, Lst, 0)
S3 = Trim(Mid(Replace(T, "/", "."), O + rr - 1, qq - rr))
U = U + Round(S1 + (S1 * S2 / 100), 2)
B = B + S1 * S3
End Select
ff = 0
pp = 0
qq = 0
rr = 0
tt = 0
ss = 0
S1 = 0
S2 = 0
S3 = 0
Next M

'' Notes : Here I add calculated results to cells
Range("D" & Target.Row).Formula = "=Round(" & A & "+" & J2 & "+" & F & "+" & ee & "+" & Q & "+" & U & ", 2)"
Range("E" & Target.Row).Formula = "=Round(" & C & "+" & L & "+" & H & "+" & gg & "+" & S & "+" & Z & ", 2)"
Range("F" & Target.Row).Formula = "=" & B & "+" & E
Range("G" & Target.Row).Formula = "=" & D & "+" & G
'' Note: Add again ALT+ENTER to the Text at the Cell

Range("A" & Target.Row).Value = Replace(T, "&", "&" & vbLf)

'MsgBox "A1 = " & A & vbCr & "B1 = " & J2 & " // " & "B2 = " & B & vbCr & "C1 = " & C & vbCr & "D1 = " & L _
& " // " & "D2 = " & D & vbCr & "E1 = " & E & vbCr & "F1 = " & F & vbCr & "G1 = " & G & vbCr & "H1 = " & _
H & vbCr & "Q1 = " & Q & vbCr & "S1 = " & S & vbCr & "U1 = " & U & vbCr & "Z1 = " & Z

End If
Resum9:
Application.FindFormat.Interior.Color = 14277081
For i = 3 To Lr1 - 1
M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i), Sheets("Work").Range("A1:A" & Lr3 + 100), 0) + 2
M = Sheets("Work").Range("A" & M1 & ":A" & Lr3 + 100).Find("", , , , , xlNext, , , True).Row - 1
Sheets("Dashboard").Range("J" & i).Formula = "=Work!B" & M
Sheets("Dashboard").Range("K" & i).Formula = "=SUM(Work!D" & M1 & ":E" & M & ")"
Sheets("Dashboard").Range("L" & i).Formula = "=SUM(Work!F" & M1 & ":G" & M & ")"
Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3 + 20), 0)
CrR = Range("A" & Cr).Address
Sheets("Dashboard").Hyperlinks.Add Anchor:=Sheets("Dashboard").Range("I" & i), Address:="", SubAddress:="'" & Sheets("Work").Name & "'!" & CrR, TextToDisplay:=Sheets("Dashboard").Range("I" & i).Value
With Sheets("Dashboard").Range("I" & i)
.Font.Underline = xlUnderlineStyleNone
.Font.ColorIndex = xlColorIndexAutomatic
.Font.Name = "Microsoft Parsi"
.Font.Size = 14
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
Next i
'  M2 = Sheets("Work").Range("A" & Lr3 + 2 & ":A" & Rows.Count - 100).Find("", , , , , xlPrevious, , , True).Row
'    Rows(M2 + 1 & ":" & Rows.Count).Hidden = True
Application.FindFormat.Clear
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub``````
understand, this is ignored and solved, awesome, Thank You

#### Unexpc

##### Active Member
and another thing, for prevent repeat insert list number, this worked until 9 and after that, numbers are repeat with two digits...

##### Well-known Member
Change this line:

VBA Code:
``If Mid(T, bb - 1, 1) = M Then GoTo NextF``

TO

VBA Code:
``If Trim(Mid(T, bb - 2, 2)) = M Then GoTo NextF``

#### Unexpc

##### Active Member
Change this line:

VBA Code:
``If Mid(T, bb - 1, 1) = M Then GoTo NextF``

TO

VBA Code:
``If Trim(Mid(T, bb - 2, 2)) = M Then GoTo NextF``
That's it, Thank You again

#### Unexpc

##### Active Member
i have problem with scroll down that till end row excel, and you try for hidden rows except cutomers (empty rows after last customer, i mean for example for this example file, without customer hidden all rows, after create customers, unhide rows for customer and when insert rows, not customer data going to hidden rows), anyway to do this?
example file: Book T=T.rar

##### Well-known Member
1. if only problem is scroll down. do it with CTRL+ down Arrow. with hiding and unhiding macro run slowly.
2. if you persist to do it with macro, which sheet you want to hide rows on it?

Replies
0
Views
183
Replies
3
Views
258
Replies
8
Views
354
Replies
0
Views
249
Replies
1
Views
178

1,186,628
Messages
5,958,883
Members
438,381
Latest member
rcwilk

### We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

### Which adblocker are you using?

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

### Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

### Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

### Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back