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

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
493
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: 23

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
493
Office Version
  1. 2019
Platform
  1. Windows
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
it does correctly! Thanks...
 
Upvote 0

Excel Facts

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

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
493
Office Version
  1. 2019
Platform
  1. Windows
Hi again maabadi
another thing that make problem for work, i use insert sheet rows and delete sheet rows button in ribbon and with this code i not test it recently but i use them and make problem for code that didn't work and wrong alignment (in edit cell) even i set it again, show this error:
 

Attachments

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

maabadi

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


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


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


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


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


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






  End If
Resum9:
  Application.FindFormat.Interior.Color = 14277081
  For i = 3 To Lr1 - 1
    M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i), Sheets("Work").Range("A1:A" & Lr3 + 100), 0) + 2
    M = Sheets("Work").Range("A" & M1 & ":A" & Lr3 + 100).Find("", , , , , xlNext, , , True).Row - 1
    Sheets("Dashboard").Range("J" & i).Formula = "=Work!B" & M
    Sheets("Dashboard").Range("K" & i).Formula = "=SUM(Work!D" & M1 & ":E" & M & ")"
    Sheets("Dashboard").Range("L" & i).Formula = "=SUM(Work!F" & M1 & ":G" & M & ")"
   Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3 + 20), 0)
   CrR = Range("A" & Cr).Address
     Sheets("Dashboard").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

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


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


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


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


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


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






  End If
Resum9:
  Application.FindFormat.Interior.Color = 14277081
  For i = 3 To Lr1 - 1
    M1 = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i), Sheets("Work").Range("A1:A" & Lr3 + 100), 0) + 2
    M = Sheets("Work").Range("A" & M1 & ":A" & Lr3 + 100).Find("", , , , , xlNext, , , True).Row - 1
    Sheets("Dashboard").Range("J" & i).Formula = "=Work!B" & M
    Sheets("Dashboard").Range("K" & i).Formula = "=SUM(Work!D" & M1 & ":E" & M & ")"
    Sheets("Dashboard").Range("L" & i).Formula = "=SUM(Work!F" & M1 & ":G" & M & ")"
   Cr = Application.WorksheetFunction.Match(Sheets("Dashboard").Range("I" & i).Value, Sheets("Work").Range("A1:A" & Lr3 + 20), 0)
   CrR = Range("A" & Cr).Address
     Sheets("Dashboard").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
understand, this is ignored and solved, awesome, Thank You
 
Upvote 0

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
493
Office Version
  1. 2019
Platform
  1. Windows
and another thing, for prevent repeat insert list number, this worked until 9 and after that, numbers are repeat with two digits...
 
Upvote 0

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
2,681
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
Change this line:

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

TO

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

Unexpc

Active Member
Joined
Nov 12, 2020
Messages
493
Office Version
  1. 2019
Platform
  1. Windows
Hi again maabadi
i have problem with scroll down that till end row excel, and you try for hidden rows except cutomers (empty rows after last customer, i mean for example for this example file, without customer hidden all rows, after create customers, unhide rows for customer and when insert rows, not customer data going to hidden rows), anyway to do this?
example file: Book T=T.rar
 
Upvote 0

maabadi

Well-known Member
Joined
Oct 22, 2012
Messages
2,681
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
1. if only problem is scroll down. do it with CTRL+ down Arrow. with hiding and unhiding macro run slowly.
2. if you persist to do it with macro, which sheet you want to hide rows on it?
 
Upvote 0

Forum statistics

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

We've detected that you are using an adblocker.

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

Which adblocker are you using?

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
Top