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:
For this I can add on line if font of symbols smaller than other text fonts then code don't add Line after &.
If this is OK tell to add code for that
Click to expand...
when i edit number, this alt+enter again between each case, any time i change, this doing this function, anyway just doing for one time?
maabadi said:
For now change font Color and Size, you see
VBA Code: 
Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size = 1
Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Color = 16777215
Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
The first line is for font size
The 2nd line for color of symbols after + and - sign.
The 3rd Line for color of & symbol
Click to expand...
for example when i delete this lines, code doing without problem?
 
Upvote 0

Excel Facts

Who is Mr Spreadsheet?
Author John Walkenbach was Mr Spreadsheet until his retirement in June 2019.
1. For disable ALT+ENTER, I add Condition to that add lines only if Font size bigger than 10 ( I describe at code with Green Color)
2. for disable lines to run add ' Symbol to the first of lines then VBA Ignore that line & don't run it. for run again it delete ' Symbol.

This is 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
Dim Lr3 As Long, Lr4 As Long, K 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

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

''' **** For disable each line add  '   symbol to disable that line at code  *****

'' Note: THis if condition check if only symbols font size > 10 then add lines to Data
If Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size > 10 Then
    Range("A" & Target.Row).Value = Replace(Range("A" & Target.Row).Value, "&", "&" & vbLf)
End If
T = Range("A" & Target.Row).Value
X = Len(T) - Len(Replace(T, "&", "")) + 1
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, 3))
   '' Note:  THis 3 row changes 1. Font size of symbols  2. Font color of them  3. font color of "&" at the end of line
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size = 1
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Color = 16777215
   Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
   O = bb + 1
For N = O To Y
If Mid(T, N, 1) = " " And IsNumeric(Mid(T, N + 1, 1)) Then P = N + 1
If IsNumeric(Mid(T, N, 1)) Or Mid(T, N, 1) = "." Or Mid(T, N, 1) = "/" Then pp = 1
If Not IsNumeric(Mid(T, N + 1, 1)) Or Mid(T, N + 1, 1) = "." Or Mid(T, N + 1, 1) = "." Then rr = 1
If pp = rr And pp > 0 Then R = N
If R >= P And P > 0 And Mid(T, N + 1, 1) = " " Or R = Len(T) Then
        If S1 = 0 Then
            S1 = Mid(Replace(T, "/", "."), P, R - P + 1)
            P = 0
            R = 0
        Else
            S2 = Mid(Replace(T, "/", "."), P, R - P + 1)
        End If
                If S2 <> S1 Then
                    Select Case cc
                    ''   ******************************************************************************** ''
                    ''  Note: Case is symbols after numbers for Order at Case to calculate Based Case Type

                            Case "+#%"
                                If S2 > 0 Then A = A + Round(S1 * (1 + S2 / 100), 2)
                            Case "+#$"
                                If S2 > 0 Then B = B + S1 * S2
                                If S2 > 0 Then J2 = J2 + S1
                            Case "-#%"
                                If S2 > 0 Then C = C + Round(S1 * (1 + S2 / 100) * -1, 2)
                            Case "-#$"
                                If S2 > 0 Then D = D + S1 * S2 * -1
                                If S2 > 0 Then L = L + S1 * -1
                            Case "+#@"
                                If S2 > 0 Then ee = ee + Round((S1 * S2) / 750, 2)
                            Case "-#@"
                                If S2 > 0 Then gg = gg + Round(-(S1 * S2) / 750, 2)
                            Case "+$"
                                E = E + S1 * 1
                            Case "+$$"
                                If S2 > 0 Then F = F + Round((S1 / S2) * 4.3318, 2)
                            Case "-$"
                                G = G + S1 * -1
                            Case "-$$"
                                If S2 > 0 Then H = H + Round((S1 / S2) * -4.3318, 2)

                    End Select
                    '' Note: Because of Case 7 & 9 we have only one number, if change symbol
                    ''       also at the next line should be symbol changes
                    If S2 > 0 Or cc = "+$" Or cc = "-$" Then
                        S1 = 0
                        S2 = 0
                        P = 0
                        R = 0
                        GoTo Resum1
                    End If
                End If
End If

 pp = 0
 rr = 0
Next N
Resum1:
Next M

'' Notes : Here I add calculated results to cells
Range("D" & Target.Row).Formula = "=Round(" & A & "+" & J2 & "+" & F & "+" & ee & ", 2)"
Range("E" & Target.Row).Formula = "=Round(" & C & "+" & L & "+" & H & "+" & gg & ", 2)"
Range("F" & Target.Row).Formula = "=" & B & "+" & E
Range("G" & Target.Row).Formula = "=" & D & "+" & G


'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



  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
Also Test this without Check Font Size:
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
Dim Lr3 As Long, Lr4 As Long, K 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

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

''' **** For disable each line add  '   symbol to disable that line at code  *****

'' Note: THis remove all ALT+ENTER in The TEXT at the Cell
    Range("A" & Target.Row).Value = Replace(Range("A" & Target.Row).Value, vbLf, "")

T = Range("A" & Target.Row).Value
X = Len(T) - Len(Replace(T, "&", "")) + 1
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, 3))
   '' Note:  THis 3 row changes 1. Font size of symbols  2. Font color of them  3. font color of "&" at the end of line
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size = 1
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Color = 16777215
   Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
   O = bb + 1
For N = O To Y
If Mid(T, N, 1) = " " And IsNumeric(Mid(T, N + 1, 1)) Then P = N + 1
If IsNumeric(Mid(T, N, 1)) Or Mid(T, N, 1) = "." Or Mid(T, N, 1) = "/" Then pp = 1
If Not IsNumeric(Mid(T, N + 1, 1)) Or Mid(T, N + 1, 1) = "." Or Mid(T, N + 1, 1) = "." Then rr = 1
If pp = rr And pp > 0 Then R = N
If R >= P And P > 0 And Mid(T, N + 1, 1) = " " Or R = Len(T) Then
        If S1 = 0 Then
            S1 = Mid(Replace(T, "/", "."), P, R - P + 1)
            P = 0
            R = 0
        Else
            S2 = Mid(Replace(T, "/", "."), P, R - P + 1)
        End If
                If S2 <> S1 Then
                    Select Case cc
                    ''   ******************************************************************************** ''
                    ''  Note: Case is symbols after numbers for Order at Case to calculate Based Case Type

                            Case "+#%"
                                If S2 > 0 Then A = A + Round(S1 * (1 + S2 / 100), 2)
                            Case "+#$"
                                If S2 > 0 Then B = B + S1 * S2
                                If S2 > 0 Then J2 = J2 + S1
                            Case "-#%"
                                If S2 > 0 Then C = C + Round(S1 * (1 + S2 / 100) * -1, 2)
                            Case "-#$"
                                If S2 > 0 Then D = D + S1 * S2 * -1
                                If S2 > 0 Then L = L + S1 * -1
                            Case "+#@"
                                If S2 > 0 Then ee = ee + Round((S1 * S2) / 750, 2)
                            Case "-#@"
                                If S2 > 0 Then gg = gg + Round(-(S1 * S2) / 750, 2)
                            Case "+$"
                                E = E + S1 * 1
                            Case "+$$"
                                If S2 > 0 Then F = F + Round((S1 / S2) * 4.3318, 2)
                            Case "-$"
                                G = G + S1 * -1
                            Case "-$$"
                                If S2 > 0 Then H = H + Round((S1 / S2) * -4.3318, 2)

                    End Select
                    '' Note: Because of Case 7 & 9 we have only one number, if change symbol
                    ''       also at the next line should be symbol changes
                    If S2 > 0 Or cc = "+$" Or cc = "-$" Then
                        S1 = 0
                        S2 = 0
                        P = 0
                        R = 0
                        GoTo Resum1
                    End If
                End If
End If

 pp = 0
 rr = 0
Next N
Resum1:
Next M

'' Notes : Here I add calculated results to cells
Range("D" & Target.Row).Formula = "=Round(" & A & "+" & J2 & "+" & F & "+" & ee & ", 2)"
Range("E" & Target.Row).Formula = "=Round(" & C & "+" & L & "+" & H & "+" & gg & ", 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(Range("A" & Target.Row).Value, "&", "&" & 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



  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
maabadi said:
for disable lines to run add ' Symbol to the first of lines then VBA Ignore that line & don't run it. for run again it delete ' Symbol.
Click to expand...
thank you, i find out
maabadi said:
For disable ALT+ENTER, I add Condition to that add lines only if Font size bigger than 10 ( I describe at code with Green Color)
Click to expand...
i test, for first time write cases and between them write & without use alt+enter, this is work correctly and doing alt+enter between cases, but when i want edit a number that cell, this is doing alt+enter again for second time, third time and... anyway just find all cases that not doing alt+enter between them and when the cases have alt+enter, don't do it again
 
Upvote 0
maabadi said:
Also Test this without Check Font Size:
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
Dim Lr3 As Long, Lr4 As Long, K 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

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

''' **** For disable each line add  '   symbol to disable that line at code  *****

'' Note: THis remove all ALT+ENTER in The TEXT at the Cell
    Range("A" & Target.Row).Value = Replace(Range("A" & Target.Row).Value, vbLf, "")

T = Range("A" & Target.Row).Value
X = Len(T) - Len(Replace(T, "&", "")) + 1
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, 3))
   '' Note:  THis 3 row changes 1. Font size of symbols  2. Font color of them  3. font color of "&" at the end of line
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size = 1
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Color = 16777215
   Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
   O = bb + 1
For N = O To Y
If Mid(T, N, 1) = " " And IsNumeric(Mid(T, N + 1, 1)) Then P = N + 1
If IsNumeric(Mid(T, N, 1)) Or Mid(T, N, 1) = "." Or Mid(T, N, 1) = "/" Then pp = 1
If Not IsNumeric(Mid(T, N + 1, 1)) Or Mid(T, N + 1, 1) = "." Or Mid(T, N + 1, 1) = "." Then rr = 1
If pp = rr And pp > 0 Then R = N
If R >= P And P > 0 And Mid(T, N + 1, 1) = " " Or R = Len(T) Then
        If S1 = 0 Then
            S1 = Mid(Replace(T, "/", "."), P, R - P + 1)
            P = 0
            R = 0
        Else
            S2 = Mid(Replace(T, "/", "."), P, R - P + 1)
        End If
                If S2 <> S1 Then
                    Select Case cc
                    ''   ******************************************************************************** ''
                    ''  Note: Case is symbols after numbers for Order at Case to calculate Based Case Type

                            Case "+#%"
                                If S2 > 0 Then A = A + Round(S1 * (1 + S2 / 100), 2)
                            Case "+#$"
                                If S2 > 0 Then B = B + S1 * S2
                                If S2 > 0 Then J2 = J2 + S1
                            Case "-#%"
                                If S2 > 0 Then C = C + Round(S1 * (1 + S2 / 100) * -1, 2)
                            Case "-#$"
                                If S2 > 0 Then D = D + S1 * S2 * -1
                                If S2 > 0 Then L = L + S1 * -1
                            Case "+#@"
                                If S2 > 0 Then ee = ee + Round((S1 * S2) / 750, 2)
                            Case "-#@"
                                If S2 > 0 Then gg = gg + Round(-(S1 * S2) / 750, 2)
                            Case "+$"
                                E = E + S1 * 1
                            Case "+$$"
                                If S2 > 0 Then F = F + Round((S1 / S2) * 4.3318, 2)
                            Case "-$"
                                G = G + S1 * -1
                            Case "-$$"
                                If S2 > 0 Then H = H + Round((S1 / S2) * -4.3318, 2)

                    End Select
                    '' Note: Because of Case 7 & 9 we have only one number, if change symbol
                    ''       also at the next line should be symbol changes
                    If S2 > 0 Or cc = "+$" Or cc = "-$" Then
                        S1 = 0
                        S2 = 0
                        P = 0
                        R = 0
                        GoTo Resum1
                    End If
                End If
End If

 pp = 0
 rr = 0
Next N
Resum1:
Next M

'' Notes : Here I add calculated results to cells
Range("D" & Target.Row).Formula = "=Round(" & A & "+" & J2 & "+" & F & "+" & ee & ", 2)"
Range("E" & Target.Row).Formula = "=Round(" & C & "+" & L & "+" & H & "+" & gg & ", 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(Range("A" & Target.Row).Value, "&", "&" & 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



  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 it does work
 
Upvote 0
That not Important. If it's your best answer mark it as solution. What is important that you find answer to your question. But if you want I add code again at the Next Post.
 
Upvote 0
This is Complete 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
Dim Lr3 As Long, Lr4 As Long, K 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

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

''' **** For disable each line add  '   symbol to disable that line at code  *****

'' Note: THis remove all ALT+ENTER in The TEXT at the Cell
    Range("A" & Target.Row).Value = Replace(Range("A" & Target.Row).Value, vbLf, "")

T = Range("A" & Target.Row).Value
X = Len(T) - Len(Replace(T, "&", "")) + 1
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, 3))
   '' Note:  THis 3 row changes 1. Font size of symbols  2. Font color of them  3. font color of "&" at the end of line
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size = 1
   Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Color = 16777215
   Range("A" & Target.Row).Characters(Start:=Y, Length:=1).Font.Color = 16777215
   O = bb + 1
For N = O To Y
If Mid(T, N, 1) = " " And IsNumeric(Mid(T, N + 1, 1)) Then P = N + 1
If IsNumeric(Mid(T, N, 1)) Or Mid(T, N, 1) = "." Or Mid(T, N, 1) = "/" Then pp = 1
If Not IsNumeric(Mid(T, N + 1, 1)) Or Mid(T, N + 1, 1) = "." Or Mid(T, N + 1, 1) = "." Then rr = 1
If pp = rr And pp > 0 Then R = N
If R >= P And P > 0 And Mid(T, N + 1, 1) = " " Or R = Len(T) Then
        If S1 = 0 Then
            S1 = Mid(Replace(T, "/", "."), P, R - P + 1)
            P = 0
            R = 0
        Else
            S2 = Mid(Replace(T, "/", "."), P, R - P + 1)
        End If
                If S2 <> S1 Then
                    Select Case cc
                    ''   ******************************************************************************** ''
                    ''  Note: Case is symbols after numbers for Order at Case to calculate Based Case Type

                            Case "+#%"
                                If S2 > 0 Then A = A + Round(S1 * (1 + S2 / 100), 2)
                            Case "+#$"
                                If S2 > 0 Then B = B + S1 * S2
                                If S2 > 0 Then J2 = J2 + S1
                            Case "-#%"
                                If S2 > 0 Then C = C + Round(S1 * (1 + S2 / 100) * -1, 2)
                            Case "-#$"
                                If S2 > 0 Then D = D + S1 * S2 * -1
                                If S2 > 0 Then L = L + S1 * -1
                            Case "+#@"
                                If S2 > 0 Then ee = ee + Round((S1 * S2) / 750, 2)
                            Case "-#@"
                                If S2 > 0 Then gg = gg + Round(-(S1 * S2) / 750, 2)
                            Case "+$"
                                E = E + S1 * 1
                            Case "+$$"
                                If S2 > 0 Then F = F + Round((S1 / S2) * 4.3318, 2)
                            Case "-$"
                                G = G + S1 * -1
                            Case "-$$"
                                If S2 > 0 Then H = H + Round((S1 / S2) * -4.3318, 2)

                    End Select
                    '' Note: Because of Case 7 & 9 we have only one number, if change symbol
                    ''       also at the next line should be symbol changes
                    If S2 > 0 Or cc = "+$" Or cc = "-$" Then
                        S1 = 0
                        S2 = 0
                        P = 0
                        R = 0
                        GoTo Resum1
                    End If
                End If
End If

 pp = 0
 rr = 0
Next N
Resum1:
Next M

'' Notes : Here I add calculated results to cells
Range("D" & Target.Row).Formula = "=Round(" & A & "+" & J2 & "+" & F & "+" & ee & ", 2)"
Range("E" & Target.Row).Formula = "=Round(" & C & "+" & L & "+" & H & "+" & gg & ", 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(Range("A" & Target.Row).Value, "&", "&" & 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



  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
Solution
You must log in or register to reply here.

Similar threads

P
  • Question
Analytics Project - Sumifs
Replies
1
Views
254
bobaol
B
S
  • Solved
Calculating Multiple Columns with SUMIFS
Replies
3
Views
234
Joe4
Joe4
B
  • Question
Excel 2021 - Sum cells that contain text for total and total by month
Replies
1
Views
84
bebo021999
B
K
  • Solved
Question Only? why one vba code works and another wont, even though should have same results.
Replies
3
Views
90
MARK858
MARK858
R
  • Solved
Connect periods with spilled result, where the result is same as the calculated result in previous row
2
Replies
15
Views
200
roelandwatteeuw
R

Forum statistics

Threads
1,215,274
Messages
6,123,993
Members
449,137
Latest member
abdahsankhan

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