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:
And symbols pasted at Column I and the Same Row
Click to expand...
anyway to find cases that belong that and when change cell, link to front of list number or if it can't, this symbols colored white and don't delete and if possible change font size that like hidden
 
Upvote 0

Excel Facts

How to create a cell-sized chart?
Tiny charts, called Sparklines, were added to Excel 2010. Look for Sparklines on the Insert tab.
Also this is Normal code to back Symbols to Data At Column A:
VBA Code: 
Sub AddSymbols()
Dim i As Long, Lr As Long, X As Long, Y As Long, M As Long, W As Long, T As String, bb As Long, S As String
Lr = Range("I" & Rows.Count).End(xlUp).Row
'' Note: Change   3 to Lr      to What rows you want to Back data to inputting format.
For i = 3 To Lr
T = Replace(Range("A" & i).Value, vbLf, "&")
S = Replace(Range("I" & i).Value, " " & vbCrLf, "&")
X = Len(S) - Len(Replace(S, "&", ""))
For M = 1 To X
If M > 1 Then W = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(S, "&", Chr(1), M - 1))
Y = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(S, "&", Chr(1), M))
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
T = Replace(T, M & Mid(T, bb, 1), M & Mid(T, bb, 1) & Mid(S, W + 1, Y - W - 1))
Next M
Range("A" & i).Value = Replace(T, "&", "&" & vbLf)
Next i
End Sub
 
Last edited:
Upvote 0
maabadi said:
Also this is Normal code to back Symbols to Data At Column A:
VBA Code: 
Sub AddSymbols()
Dim i As Long, Lr As Long, X As Long, Y As Long, M As Long, W As Long, T As String, bb As Long, S As String
Lr = Range("I" & Rows.Count).End(xlUp).Row
'' Note: Change   3 to Lr      to What rows you want to Back data to inputting format.
For i = 3 To Lr
T = Replace(Range("A" & i).Value, vbLf, "&")
Debug.Print T
S = Replace(Range("I" & i).Value, " " & vbCrLf, "&")
X = Len(S) - Len(Replace(S, "&", ""))
For M = 1 To X
If M > 1 Then W = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(S, "&", Chr(1), M - 1))
Y = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(S, "&", Chr(1), M))
bb = Application.WorksheetFunction.Find(Chr(1), Application.WorksheetFunction.Substitute(Replace(T, "+", "-"), "-", Chr(1), M))
T = Replace(T, M & Mid(T, bb, 1), M & Mid(T, bb, 1) & Mid(S, W + 1, Y - W - 1))
Debug.Print T
Next M
Range("A" & i).Value = Replace(T, "&", "&" & vbLf)
Next i
End Sub
Click to expand...
i test and add, but result is zero, but if possible test change color font, this is less hassle
 
Upvote 0
Unexpc said:
8 not calculate in D
Click to expand...
Case 8 Result is 3.02 and if you see D column at formula bar you see it calculated at formula.
Unexpc said:
anyway to find cases that belong that and when change cell, link to front of list number or if it can't, this symbols colored white and don't delete and if possible change font size that like hidden
Click to expand...
But for Print time you should test it Not print symbols if you don't want them.
 
Upvote 0
maabadi said:
Case 8 Result is 3.02 and if you see D column at formula bar you see it calculated at formula.
Click to expand...
Case 10 like case 8 and case 10 calculate and sum in Column E but Case 8 i calculate by myself for check calculation, this not calculated
maabadi said:
But for Print time you should test it Not print symbols if you don't want them.
Click to expand...
i don't print this texts (Column A), i don't want them
 
Upvote 0
Unexpc said:
Case 10 like case 8 and case 10 calculate and sum in Column E but Case 8 i calculate by myself for check calculation, this not calculated
Click to expand...
I use space between numbers to define numbers from text, but you forgot to add space before 230000 at Case 8. after adding Space macro =works Correctly.

This is Change Color Font for Symbols
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
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))
   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
'Range("A" & Target.Row) = T

'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:
I use space between numbers to define numbers from text, but you forgot to add space before 230000 at Case 8. after adding Space macro =works Correctly.
Click to expand...
=works correctly :) sorry again
and symbols doing right, just two thing, change font size of symbols to 1 and alt+enter doing with &
 
Upvote 0
Unexpc said:
symbols doing right, just two thing, change font size of symbols to 1 and alt+enter doing with &
Click to expand...
For First No Problem. After this line:
VBA Code: 
cc = Trim(Mid(T, bb, 3))
Add one ENTER AND
Add this line of Code :
VBA Code: 
Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size = 1

if you don't have ALT+ENTER at inputted Data. You can Do it. Then Add Before This Line of Code:
VBA Code: 
T = Range("A" & Target.Row).Value
Add This Line of Code;
VBA Code: 
Range("A" & Target.Row).Value = Replace(Range("A" & Target.Row).Value, "&", "&" & vbLf)
 
Upvote 0
maabadi said:
For First No Problem. After this line:
VBA Code: 
cc = Trim(Mid(T, bb, 3))
Add one ENTER AND
Add this line of Code :
VBA Code: 
Range("A" & Target.Row).Characters(Start:=bb + 1, Length:=2).Font.Size = 1

if you don't have ALT+ENTER at inputted Data. You can Do it. Then Add Before This Line of Code:
VBA Code: 
T = Range("A" & Target.Row).Value
Add This Line of Code;
VBA Code: 
Range("A" & Target.Row).Value = Replace(Range("A" & Target.Row).Value, "&", "&" & vbLf)
Click to expand...
yes, works correctly, just when i edit number, & function (alt+enter) doing again, and if you want and this correct, write by yourself i marked as solution
and please say how can i change symbols and delete line that belong the font color and size, maybe later i edit font for this symbols but for now this is very good and like hidden


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
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))
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
'Range("A" & Target.Row) = T

'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
 
Last edited:
Upvote 0
Unexpc said:
just when i edit number, & function (alt+enter) doing again
Click to expand...
1. 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
Unexpc said:
please say how can i change symbols
Click to expand...
If you right-click on WORK sheet and select view code, you see worksheet change event code.
At this code, I add notes with Light- Green Color. Read them to Know where is symbols ( at Select Case section).
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
 
Upvote 0
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,989
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