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

U

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
496
Office Version
  1. 2019
Platform
  1. Windows
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
    image_2021-07-16_183906.png
    20.9 KB · Views: 24
Sort by date Sort by votes
maabadi said:
Try this:
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
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
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

  If Target.Interior.Color = 14277081 Then
  If Target.Value <> "" Then
  Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
  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 = 2 To X
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
If Mid(T, bb - 1, 1) = 2 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 * S2 / S3), 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 * S2 / S3), 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
                        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
  For i = 3 To Lr1 - 1
   Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3), 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
  Application.EnableEvents = True
End Sub
Click to expand...
yes, this is work correctly, just add number 1 automatically, this code not added number, at first i use | character for excel error, so number 1 is automatically added like other list number, thank you
 
Upvote 0

Excel Facts

Can a formula spear through sheets?
Use =SUM(January:December!E7) to sum E7 on all of the sheets from January through December
maabadi said:
Try this:
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
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
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

  If Target.Interior.Color = 14277081 Then
  If Target.Value <> "" Then
  Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
  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 = 2 To X
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
If Mid(T, bb - 1, 1) = 2 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 * S2 / S3), 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 * S2 / S3), 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
                        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
  For i = 3 To Lr1 - 1
   Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3), 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
  Application.EnableEvents = True
End Sub
Click to expand...
Unexpc said:
yes, this is work correctly, just add number 1 automatically, this code not added number, at first i use | character for excel error, so number 1 is automatically added like other list number
Click to expand...
please just fix this, im very thankful, and i very happy for solved the space between symbols and this list number you solved, what's left just fix this, i want like add 2,3,4,5... add 1 automatically...
 
Upvote 0
maabadi said:
Try this:
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
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
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

  If Target.Interior.Color = 14277081 Then
  If Target.Value <> "" Then
  Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
  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 = 2 To X
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
If Mid(T, bb - 1, 1) = 2 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 * S2 / S3), 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 * S2 / S3), 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
                        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
  For i = 3 To Lr1 - 1
   Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3), 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
  Application.EnableEvents = True
End Sub
Click to expand...
for added number 1, i compare with two codes you send, i edit last code, this is may right, please see it
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
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
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


  If Target.Interior.Color = 14277081 Then
  If Target.Value <> "" Then
  Range("A" & Target.Row & ":G" & Target.Row + Target.Value - 1).Insert Shift:=xlDown
  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 * S2 / S3), 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 * S2 / S3), 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
                        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
  For i = 3 To Lr1 - 1
   Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3), 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
  Application.EnableEvents = True
End Sub
 
Upvote 0
and like ever, you solved the complex thread, you many helps in my work, this is the best function that i want, and
THANK YOU><><><><><><><><><><><><><> :)
 
Upvote 0
maabadi said:
.
Click to expand...
Hi mabaadi, this really very very helpful for my work and i so many thankful you :)
please help me in this 3 things :
1. a new case : #%$, example and calculation : first photo (and if can please how can i create cases, i see your code but i can't find out)
2. for insert automatic list number, when i write for first this is insert, but when i want edit that cell and write new item or case, list number for new cases i write is not inserted
3. for some cells, appear error checking, anyway to ignore that? (second photo)
 

Attachments

  • image_2021-10-30_140858.png
    image_2021-10-30_140858.png
    12.5 KB · Views: 7
  • image_2021-10-30_141220.png
    image_2021-10-30_141220.png
    803 bytes · Views: 8
Upvote 0
Last Work Code :
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) = 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
                        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
 
Upvote 0
Unexpc said:
1. a new case : #%$, example and calculation : first photo (and if can please how can i create cases, i see your code but i can't find out)
Click to expand...
Try this:
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) = 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
Unexpc said:
for insert automatic list number, when i write for first this is insert, but when i want edit that cell and write new item or case, list number for new cases i write is not inserted
Click to expand...
I don't Think Excel allow insert automatic numbering within Cell
 
Upvote 0
maabadi said:
Try this:
Click to expand...
Correct! thanks a lot :)
maabadi said:
I don't Think Excel allow insert automatic numbering within Cell
Click to expand...
i don't know, but for now in this code added list number for first time that cell written and if you remember, for second time insert again but wrong, for example
for first time
1
2
3
but when i edit that cell this happened
11
22
33
and you set that not happened, i say second question that if can, this happened
i write for first and insert number automatically
1 +a
2 -b
3 +c
but when i added a new item in that cell this don't added number
1 +a
2 -b
3 +c
-d (not added 4 for example)
i mean this
 
Last edited:
Upvote 0
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").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
 
Upvote 0
You must log in or register to reply here.

Similar threads

P
  • Question
Analytics Project - Sumifs
Replies
1
Views
178
bobaol
B
S
  • Solved
Calculating Multiple Columns with SUMIFS
Replies
3
Views
182
Joe4
Joe4
R
  • Solved
Connect periods with spilled result, where the result is same as the calculated result in previous row
2
Replies
15
Views
153
roelandwatteeuw
R
M
  • Solved
How to sum a row of data with some cells containing an extra character
2
Replies
10
Views
669
Fluff
Fluff
N
  • Solved
Sum a range of cells defined by a string
Replies
4
Views
190
Nerdio
N

Forum statistics

Threads
1,214,642
Messages
6,120,698
Members
448,979
Latest member
DET4492

Share this page

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?

Disable AdBlock

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
Back
Top