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) = 1 Then Exit For
T = Left(T, bb - 1) & M & Right(T, Len(T) - bb + 1)
Next M
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 cc
Debug.Print Mid(T, O, Y - O + 2)
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").Range("I" & i).Hyperlinks.Delete
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