'v.1.1.20
'Code is totally rewriten.
'Increased speed of calculation.

Sub CalculateBonusMacros()
    Application.ScreenUpdating = False
    Dim WS As Worksheet
    'If Init(WS, True, "Bonus") Then
    '    End Sub
    '    Call CalculateProfit(WS, "Bonus")
    'End If
    Application.ScreenUpdating = True
End Sub

Sub CalculateDailyRevenueMacros()
    Application.ScreenUpdating = False
    Dim WS As Worksheet
    If Init(WS, True, "Daily revenue") Then
        Call CalculateProfit(WS, "Daily revenue")
    End If
    Application.ScreenUpdating = True
End Sub
'_________________________________________________________________________________________________________________________________________________

Private Type Manager
    Dim NickName As String
    Dim RealName As String
    Dim City As String
End Sub

Private Type Exchange
    Dim ExchangeType As String
    Dim Day As String
    Dim ProjectName As String
    Dim Description As String
    Dim Amount(17) As Double
    Dim ExchangeRate As Double
    Dim Manager As Long
    Dim BuyOrSell As String
    Dim Pair As Long
    Dim Profit As Double
    Dim CurrencyNumber As Long
    Dim ProfitPercentage As Double
    Dim DealNumber As Long
    Dim Errors As String
End Sub

Dim numberOfManagers, numberOfExchanges As Long
Dim managers(4) As Manager
Dim CurrencyNames(16), MonthToCalculate As String
Dim exchanges() As Exchange
Dim exchangesCopy() As Exchange

Function Inc(ByRef val As Variant, Optional ByVal add As Variant = 1) As Variant
    val = val + add
    Inc = val
End Function

Sub InitManager(NickName As String, RealName As String, City As String)
    Inc numberOfManagers
    With Manager(numberOfManagers)
        .NickName = NickName
        .RealName = RealName
        .City = City
    End With
End Sub

Function Init(ByRef WS As Worksheet, clear As Boolean, ByVal buttonName As String) As Boolean
    Dim f As Boolean
    Dim newSheetName, s As String
    Dim i, j, k, cnt, cntNegative, cntPositive, cntErrors As Long

    Call InitManager("ë", "Ë", "Moscow")
    Call InitManager("þ", "Þ", "Moscow")
    Call InitManager("ï", "Ï", "Moscow")

    k = 1
    For j = 5 To 17
        If j = 6 Then j = 7
        CurrencyNames(k) = Cells(1, j).Value
        Inc k
    Next j

    f = False
    'Set the name of new sheet
    If buttonName = "Bonus" Then
        If IsEmpty(Cells(1, 18).Value) Then
            MsgBox "Ââåäèòå ìåñÿö"
            End
        Else
            newSheetName = "Bonus - " & Cells(1, 18).Value
        End If
    Else
        If IsEmpty(Cells(1, 18).Value) Then
            MsgBox "Ââåäèòå ìåñÿö"
            End
        Else
            newSheetName = "Daily revenue - " & Cells(1, 18).Value
        End If
    End If
    'If There is already sheet with such name, then don't create a new sheet ...
    For Each it In Sheets
        If it.Name = newSheetName Then
            Set WS = it
            f = True
            If clear Then WS.Cells.clear
        End If
    Next it
    '... but if there not such sheet, then create a new one
    If f = False Then
        s = ActiveSheet.Name
        Set WS = Sheets.add
        WS.Name = newSheetName
        Worksheets(s).Activate
    End If

    WS.Visible = True

    Range("A1:R1").Copy WS.Range("A1:R1")
    Range("E2:R2").Copy WS.Range("E2:R2")

    Call DelButtons(WS)

    MonthToCalculate = Cells(1, 18).Value


    'Copy exchanges from the month
    j = 3
    Do While IsEmpty(Cells(j, 1).Value) = False
        j = j + 1
    Loop
    ReDim exchanges(j)

    numberOfExchanges = 0
    For i = 3 To Rows.Count
        If IsEmpty(Cells(i, 1).Value) Then
            Exit For
        End If
        If GoodDay(Cells(i, 2).Value) = False Then Next i
        If Cells(i, 1).Value = "îáìåí" And Cells(i, 4).Value <> "Íåó÷òåííûé äîõîä" And Cells(i, 4).Value <> "Íåó÷òåííûé ðàñõîä" And Cells(i, 1).Interior.Color <> vbRed Then
            cnt = 0
            cntPositive = 0
            cntNegative = 0
            For k = 5 To 17
                If k <> 6 And IsEmpty(Cells(i, k).Value) = False Then
                    If Cells(i, k).Value <> 0 Then cnt = cnt + 1
                    If Cells(i, k).Value > 0 Then cntPositive = cntPositive + 1
                    If Cells(i, k).Value < 0 Then cntNegative = cntNegative + 1
                End If
            Next k
            If cnt >= 2 And cntPositive > 0 And cntNegative > 0 Then
                numberOfExchanges = numberOfExchanges + 1
                exchanges(numberOfExchanges).ExchangeType = WS.Cells(i, 1).Value
                exchanges(numberOfExchanges).Day = WS.Cells(i, 2).Value
                exchanges(numberOfExchanges).ProjectName = WS.Cells(i, 3).Value
                exchanges(numberOfExchanges).Description = WS.Cells(i, 4).Value
                If IsEmpty(WS.Cells(i, 6).Vlaue) Then
                    exchanges(numberOfExchanges).ExchangeRate = -1
                Else
                    exchanges(numberOfExchanges).ExchangeRate = WS.Cells(i, 6).Value
                End If
                k = 1
                For j = 5 To 17
                    If j = 6 Then j = 7
                    If IsEmpty(WS.Cells(i, j).Value) = False Then
                        exchanges(numberOfExchanges).Amount(k) = WS.Cells(i, j).Value
                    Else
                        exchanges(numberOfExchanges).Amount(k) = 0
                    End If
                    k = k + 1
                Next j
                exchanges(numberOfExchanges).Manager = 0
                If IsEmpty(WS.Cells(i, 18).Value) = False Then
                    For j = 1 To numberOfManagers
                        If WS.Cells(i, 18).Value = Manager(j).NickName Then
                            exchanges(numberOfExchanges).Manager = j
                        End If
                    Next j
                End If
                exchanges(numberOfExchanges).BuyOrSell = ""
                exchanges(numberOfExchanges).Pair = -1
                exchanges(numberOfExchanges).Profit = 0#
                exchanges(numberOfExchanges).CurrencyNumber = 0
                exchanges(numberOfExchanges).DealNumber = 0
                exchanges(numberOfExchanges).Errors = ""
            End If
        End If
    Next i
    WS.Cells(1, 1).EntireColumn.AutoFit
    WS.Cells(1, 2).EntireColumn.AutoFit
    WS.Cells(1, 3).EntireColumn.AutoFit
    WS.Cells(1, 4).EntireColumn.AutoFit
    WS.Cells(1, 5).EntireColumn.AutoFit
    'MsgBox "Init"
End Function

Private Function calculateNumberOfLines(ByRef WS As Worksheet) As Long
    Dim answer As Long
    answer = 2
    Do While IsEmpty(WS.Cells(answer + 1, 1).Value) = False
        answer = answer + 1
    Loop
    calculateNumberOfLines = answer
End Function

Sub DelButtons(ByRef WS As Worksheet)
    Dim btn As Shape
    For Each btn In WS.Shapes
        If btn.AutoShapeType = msoShapeStyleMixed Then btn.Delete
    Next
End Sub

Private Sub InitDSU(ByRef pr() As Long, ByRef sz() As Long, ByVal n As Long)
    Dim i As Long
    For i = 0 To n
        pr(i) = i
        sz(i) = 1
    Next i
End Sub
Private Function getInDSU(ByRef pr() As Long, ByVal v As Long) As Long
    If pr(v) = v Then
        getInDSU = v
    Else
        Dim cur As Long
        cur = getInDSU(pr, pr(v))
        pr(v) = cur
        getInDSU = cur
    End If
End Function
Private Function uniteInDsu(ByRef pr() As Long, ByRef sz() As Long, ByVal a As Long, ByVal b As Long) As Long
    a = getInDSU(pr, a)
    b = getInDSU(pr, b)
    If (a <> b) Then
        pr(b) = a
        sz(a) = sz(a) + sz(b)
        uniteInDsu = a
    Else
        uniteInDsu = -1
    End If
End Function

'Just simple max
Function Max(a As Double, b As Double) As Double
    If a > b Then
        Max = a
    Else
        Max = b
    End If
End Function
'Just simple min
Function Min(a As Double, b As Double) As Double
    If a < b Then
        Min = a
    Else
        Min = b
    End If
End Function
'Just abs for doubles
Function DoubleAbs(a As Double) As Double
    If a < 0 Then
        DoubleAbs = -a
    Else
        DoubleAbs = a
    End If
End Function

Sub SaveExchanges()
    Dim i, j As Long
    ReDim exchangesCopy(numberOfExchanges + 1)
    For i = 1 To numberOfExchanges
        exchangesCopy(i).ExchangeType = exchanges(i).ExchangeType
        exchangesCopy(i).Day = exchanges(i).Day
        exchangesCopy(i).ProjectName = exchanges(i).ProjectName
        exchangesCopy(i).Description = exchanges(i).Description
        For j = 1 To 12
            exchangesCopy(i).Amount(j) = exchanges(i).Amount(j)
        Next j
        exchangesCopy(i).ExchangeRate = exchanges(i).ExchangeRate
        exchangesCopy(i).Manager = exchanges(i).Manager
        exchangesCopy(i).BuyOrSell = exchanges(i).BuyOrSell
        exchangesCopy(i).Pair = exchanges(i).Pair
        exchangesCopy(i).Profit = exchanges(i).Profit
        exchangesCopy(i).CurrencyNumber = exchanges(i).CurrencyNumber
    Next i
End Sub

Sub LoadExchanges()
    Dim i, j As Long
    For i = 1 To numberOfExchanges
        exchanges(i).ExchangeType = exchangesCopy(i).ExchangeType
        exchanges(i).Day = exchangesCopy(i).Day
        exchanges(i).ProjectName = exchangesCopy(i).ProjectName
        exchanges(i).Description = exchangesCopy(i).Description
        For j = 1 To 12
            exchanges(i).Amount(j) = exchangesCopy(i).Amount(j)
        Next j
        exchanges(i).ExchangeRate = exchangesCopy(i).ExchangeRate
'        exchanges(i).Manager = exchangesCopy(i).Manager
'        exchanges(i).BuyOrSell = exchangesCopy(i).BuyOrSell
'        exchanges(i).Pair = exchangesCopy(i).Pair
'        exchanges(i).Profit = exchangesCopy(i).Profit
'        exchanges(i).CurrencyNumber = exchangesCopy(i).CurrencyNumber
    Next i
End Sub

'Delete leading zeroes from a string
Private Function DeleteZeroes(ByVal s As String) As String
    Dim res As String
    Dim f As Boolean
    f = False
    For i = 1 To Len(s)
        If Mid(s, i, 1) <> "0" Then f = True
        If f Then res = res & Mid(s, i, 1)
    Next i
    DeleteZeroes = res
End Function

'Check that exchange is made in the needed month
Private Function GoodDay(ByVal s As String) As Boolean
    Dim need As String
    need = DeleteZeroes(MonthToCalculate)
    If need = "" Then
        GoodDay = True
    Else
        Dim american As Boolean
        american = True
        Dim i As Long
        For i = 1 To Len(s)
            If Mid(s, i, 1) = "." Then american = False
        Next i
        Dim res As String
        res = ""
        If american Then
            Dim cntslash As Long
            cntslash = 0
            For i = 1 To Len(s)
                If Mid(s, i, 1) = "/" Then cntslash = cntslash + 1
                If cntslash Mod 2 = 0 Then
                    If Mid(s, i, 1) = "/" Then
                        res = res & "."
                    Else
                        res = res & Mid(s, i, 1)
                    End If
                End If
            Next i
        Else
            cntslash = 0
            For i = 1 To Len(s)
                If cntslash > 0 Then
                    res = res & Mid(s, i, 1)
                End If
                If Mid(s, i, 1) = "." Then cntslash = cntslash + 1
            Next i
        End If
        res = DeleteZeroes(res)
        If res = need Then
            GoodDay = True
        Else
            GoodDay = False
        End If
    End If
End Function

Private Sub LeaveOnlyMarked(ByRef WS As Worksheet)
    'useless function
End Sub

'return -1 if profit < 0.1%, 1 if > 2%, 0 if [0.1 ... 2]%, -228 otherwise
Private Function getTypeByProfit(ByRef WS As Worksheet, ByVal i, ByRef ExchangeRate() As Double) As Long
    getTypeByProfit = 0
    Dim posBuy, j As Long
    Dim sum As Double

    posBuy = -1
    If exchanges(i).CurrencyNumber <> 0 Then posBuy = exchanges(i).CurrencyNumber

    If (posBuy = -1) Then
        getTypeByProfit = -228
    Else
        sum = 0
        For j = 1 To 12
            If exchanges(i).Amount(j) <> 0 Then
                If (getExchangeRate(WS, i, posBuy, j, ExchangeRate) = -1) Then
                    getTypeByProfit = -228
                    Exit For
                Else
                    sum = sum + DoubleAbs(exchanges(i).Amount(j)) * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
                End If
            End If
        Next j
        sum = sum / 2
        If sum = 0 Then getTypeByProfit = -228
        If getTypeByProfit = 0 Then
            exchanges(i).ProfitPercentage = exchanges(i).Profit / sum * 100#
            If exchanges(i).ProfitPercentage < 0.1 Then getTypeByProfit = -1
            If exchanges(i).ProfitPercentage > 2# Then getTypeByProfit = 1
        End If
    End If
End Function


'Calculate overal profit from exchanges and print them at the end of the table
Private Sub CalculateSummary(ByRef WS As Worksheet, ByRef ExchangeRate() As Double)
    Dim i As Long, j As Long, cnt As Long, k As Long
    Dim sumL(13), sumU(13), sumTotal(13), profitTotal(13), sumOverAllExchanges(13) As Double

    For i = 1 To 12
        sumL(i) = 0
        sumU(i) = 0
        profitTotal(i) = 0
        sumOverAllExchanges(i) = 0
        If i > 4 Then
            sumTotal(i) = 0
            'If IsEmpty(WS.Cells(2, i).Value) = False Then sumTotal(i) = WS.Cells(2, i).Value
        End If
    Next i

    Dim names(101) As String
    Dim sumExpenses(101, 18) As Double
    Dim cntNames As Long
    cntNames = 2
    names(0) = "Total" + " expenses"
    names(1) = "Red lines" + " expenses"
    For i = 3 To Rows.Count
        If IsEmpty(Cells(i, 1).Value) Then Exit For
        Dim s As String
        s = Cells(i, 2).Value
        If GoodDay(s) Then
            For j = 5 To 17
                If j = 6 Then j = j + 1
                If IsNumeric(Cells(i, j).Value) Then
                    sumOverAllExchanges(j) = sumOverAllExchanges(j) + Cells(i, j).Value
                End If
            Next j
            If Cells(i, 3).Value = "suex.io-ex" And (Cells(i, 1).Value = "îáìåí" Or (Cells(i, 4).Value Like "*åó÷òåí*") Or (Cells(i, 4).Value Like "*îìèññèÿ*")) And Cells(i, 1).Interior.Color <> vbRed Then
                'If (Cells(i, 4).Value Like "*åó÷òåí*") Or (Cells(i, 4).Value Like "*îìèññèÿ*") Then MsgBox i
                For j = 5 To 17
                    If j = 6 Then j = j + 1
                        If IsNumeric(Cells(i, j).Value) Then
                            sumTotal(j) = sumTotal(j) + Cells(i, j).Value
                        End If
                Next j
            End If
            If Cells(i, 1).Value = "ðàñõîä" Then
                Dim curPos As Long
                curPos = 0
                Do While curPos < cntNames And names(curPos) <> (Cells(i, 3).Value + " expenses")
                    curPos = curPos + 1
                Loop
                If Cells(i, 1).Interior.Color = vbRed Then
                    curPos = 1
                Else
                    If (curPos = cntNames) Then
                        names(curPos) = Cells(i, 3).Value + " expenses"
                        cntNames = cntNames + 1
                    End If
                End If
                For j = 5 To 17
                    If j = 6 Then j = j + 1
                    If IsNumeric(Cells(i, j).Value) Then
                        If curPos <> 1 Then sumExpenses(0, j) = sumExpenses(0, j) + Cells(i, j).Value
                        sumExpenses(curPos, j) = sumExpenses(curPos, j) + Cells(i, j).Value
                    End If
                Next j
            End If
        End If
    Next i
    Dim cntNotEmpty As Long
    cntNotEmpty = 0
    For i = 3 To WS.Rows.Count
        If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
        If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If
        WS.Cells(i, 22).Value = ""
        If IsEmpty(WS.Cells(i, 19).Value) = False Then
            WS.Cells(i, 19).Value = WS.Cells(i, 19).Value / 2#
        End If
        Dim typeByProfit As Long
        typeByProfit = getTypeByProfit(WS, i, ExchangeRate)
        If (typeByProfit <> -228) Then
            If typeByProfit = -1 Then
                For j = 1 To 20
                    WS.Cells(i, j).Interior.Color = vbYellow
                Next j
            End If
            If typeByProfit = 1 Then
                For j = 1 To 20
                    WS.Cells(i, j).Interior.Color = vbGreen
                Next j
            End If
        Else
            For j = 1 To 20
                WS.Cells(i, j).Interior.Color = vbRed
            Next j
        End If

        If IsEmpty(WS.Cells(i, 20).Value) = False Then
            j = 5
            Do While j <= 17 And WS.Cells(1, j).Value <> WS.Cells(i, 20).Value
                j = j + 1
            Loop

            If WS.Cells(i, 18).Value = "ë" Then sumL(j) = sumL(j) + WS.Cells(i, 19).Value
            If WS.Cells(i, 18).Value = "þ" Then sumU(j) = sumU(j) + WS.Cells(i, 19).Value
            profitTotal(j) = profitTotal(j) + WS.Cells(i, 19).Value

            WS.Cells(i, 21).Value = ""
            cntNotEmpty = cntNotEmpty + 1
        End If
    Next i
    For j = 5 To 17
        WS.Cells(i + 1, j).Value = WS.Cells(1, j).Value
        WS.Cells(i + 2, j).Value = sumTotal(j)
        WS.Cells(i + 5, j).Value = profitTotal(j)
        WS.Cells(i + 8, j).Value = sumL(j)
        WS.Cells(i + 9, j).Value = sumU(j)
    Next j

    WS.Cells(i + 2, 4).Value = "Total"
    Call CalculateTotalIn(WS, 5, i + 3, i + 2, ExchangeRate)
    Call CalculateTotalIn(WS, 7, i + 4, i + 2, ExchangeRate)
    WS.Cells(i + 2, 4).Value = "Total (calculated as a simple sum)"
    For k = i + 2 To i + 4
        For j = 4 To 17
            WS.Cells(k, j).Interior.Color = vbGreen
        Next j
    Next k

    WS.Cells(i + 5, 4).Value = "Total profit"
    Call CalculateTotalIn(WS, 5, i + 6, i + 5, ExchangeRate)
    Call CalculateTotalIn(WS, 7, i + 7, i + 5, ExchangeRate)
    WS.Cells(i + 5, 4).Value = "Total profit (calculated as a simple sum)"
    For k = i + 5 To i + 7
        For j = 4 To 17
            WS.Cells(k, j).Interior.Color = vbCyan
        Next j
    Next k

    WS.Cells(i + 8, 4).Value = "Ïðèáûëü Ë"
    WS.Cells(i + 9, 4).Value = "Ïðèáûëü Þ"
    For j = 4 To 17
        WS.Cells(i + 8, j).Interior.Color = vbYellow
        WS.Cells(i + 9, j).Interior.Color = RGB(255, 120, 200)
    Next j

    names(cntNames) = "Sum over all exchanges"
    For j = 5 To 17
        sumExpenses(cntNames, j) = sumOverAllExchanges(j)
    Next j
    cntNames = cntNames + 1
    For k = 0 To cntNames - 1
        For j = 5 To 17
            WS.Cells(i + 12 + k * 3, j).Value = sumExpenses(k, j)
        Next j
        WS.Cells(i + 12 + k * 3, 4).Value = names(k)
        Call CalculateTotalIn(WS, 5, i + 13 + k * 3, i + 12 + k * 3, ExchangeRate)
        Call CalculateTotalIn(WS, 7, i + 14 + k * 3, i + 12 + k * 3, ExchangeRate)
        If k = 0 Then
            WS.Cells(i + 12 + k * 3, 4).Value = CStr(WS.Cells(i + 12 + k * 3, 4).Value + " (calculated as a simple sum)")
        End If
        For j = 4 To 17
            WS.Cells(i + 12 + k * 3, j).Interior.Color = RGB(255 - k - 1, 255, 255)
            WS.Cells(i + 13 + k * 3, j).Interior.Color = RGB(255 - k - 1, 255, 255)
            WS.Cells(i + 14 + k * 3, j).Interior.Color = RGB(255 - k - 1, 255, 255)
        Next j
        If k = cntNames - 1 Then
            For j = 4 To 17
                WS.Cells(i + 12 + k * 3, j).Interior.Color = RGB(30, 200, 0)
                WS.Cells(i + 13 + k * 3, j).Interior.Color = RGB(30, 200, 0)
                WS.Cells(i + 14 + k * 3, j).Interior.Color = RGB(30, 200, 0)
            Next j
        End If
    Next k

    'MsgBox "CalculateSummary " & cntNotEmpty
End Sub


'Calculate overal profit from exchanges and print them at the end of the table
Private Function printBonus(ByRef WS As Worksheet) As Long
    Dim i As Long, j As Long, cnt As Long, k As Long
    Dim sumL(17) As Double, sumU(17) As Double
    For i = 1 To 17
        sumL(i) = 0
        sumU(i) = 0
    Next i
    For i = 3 To WS.Rows.Count
        If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
        If IsEmpty(WS.Cells(i, 19).Value) = False Then
            j = 5
            Do While j <= 17 And WS.Cells(1, j).Value <> WS.Cells(i, 19).Value
                j = j + 1
            Loop

            If WS.Cells(i, 24).Value = "ë" Then sumL(j) = sumL(j) + WS.Cells(i, 23).Value
            If WS.Cells(i, 24).Value = "þ" Then sumU(j) = sumU(j) + WS.Cells(i, 23).Value
        End If
    Next i
    For j = 5 To 17
        WS.Cells(i + 10, j).Value = CDbl(sumL(j))
        WS.Cells(i + 10, j).NumberFormat = "0.00"
        WS.Cells(i + 11, j).Value = CDbl(sumU(j))
        WS.Cells(i + 11, j).NumberFormat = "0.00"
    Next j
    WS.Cells(i + 10, 4).Value = "Áîíóñ Ë"
    WS.Cells(i + 11, 4).Value = "Áîíóñ Þ"
    For j = 4 To 17
        WS.Cells(i + 10, j).Interior.Color = vbYellow
        WS.Cells(i + 11, j).Interior.Color = RGB(255, 120, 200)
    Next j
    printBonus = i + 11
    Do While IsEmpty(WS.Cells(printBonus + 1, 4).Value) = False
        printBonus = printBonus + 1
    Loop
End Function

Private Sub calculateSumOfProfit(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef sumOfProfit() As Double)
    Dim i, j As Long
    Dim add As Double

    Call RecalculateExchangeRates(WS, i, ExchangeRate, 3)
    For i = 1 To numberOfExchanges
        If i > 1 And exchanges(i).Day <> exchanges(i - 1).Day Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If
        If exchanges(i).CurrencyNumber <> 0 And exchanges(i).DealNumber <> 0 Then
            add = exchanges(i).Profit * getExchangeRate(WS, i, 2, exchanges(i).CurrencyNumber, ExchangeRate)
            sumOfProfit(exchanges(i).DealNumber) = sumOfProfit(exchanges(i).DealNumber) + add
        End If
    Next i
End Sub

Private Sub calculateDealSum(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef dealBuySum() As Double, ByRef dealSellSum() As Double, ByRef dealType() As String)
    Dim i, j As Long
    Dim sumPositive, sumNegative As Double
    Dim positiveFlag, negativeFlag As Boolean
    Dim posBuy, cnt As Long
    Dim sum As Double

    Call RecalculateExchangeRates(WS, i, ExchangeRate, 3)
    For i = 1 To numberOfExchanges
        If i > 1 And exchanges(i).Day <> exchanges(i - 1).Day Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If

        If exchanges(i).DealNumber <> 0 Then
            positiveFlag = True
            negativeFlag = True
            sumPositive = 0
            sumNegative = 0

            posBuy = exchanges(i).CurrencyNumber
            If posBuy <> 0 Then
                For j = 1 To 12
                    If exchanges(i).Amount(j) <> 0 Then
                        If exchanges(i).Amount(j) < 0 Then
                            If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
                                sumNegative = sumNegative - exchanges(i).Amount(j) * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
                            Else
                                negativeFlag = False
                            End If
                        End If
                        If exchanges(i).Amount(j) > 0 Then
                            If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
                                sumPositive = sumPositive + exchanges(i).Amount(j) * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
                            Else
                                positiveFlag = False
                            End If
                        End If
                    End If
                Next j

                cnt = 0
                sum = 0
                If positiveFlag Then
                    cnt = cnt + 1
                    sum = sum + sumPositive
                End If
                If negativeFlag Then
                    cnt = cnt + 1
                    sum = sum + sumNegative
                End If
                If (cnt <> 0) Then
                    If (dealType(i) = "Buy") Then
                        If positiveFlag Then
                            sum = sumPositive
                            cnt = 1
                        End If
                        dealBuySum(exchanges(i).DealNumber) = dealBuySum(exchanges(i).DealNumber) + (sum / cnt)
                    Else
                        If positiveFlag Then
                            sum = sumPositive
                            cnt = 1
                        End If
                        dealSellSum(exchanges(i).DealNumber) = dealSellSum(exchanges(i).DealNumber) + (sum / cnt)
                    End If
                Else
                    exchanges(i).Errors = exchanges(i).Errors + "(calculateDealSum error) "
                End If
            End If
        End If
    Next i
End Sub

Private Sub calculateBonusWithDealSum(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef dealBuySum() As Double, ByRef dealSellSum() As Double, ByRef dealType() As String)
    Dim i As Long
    For i = 3 To WS.Rows.Count
        If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
        If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If
        If IsEmpty(WS.Cells(i, 22).Value) = False Then
            Dim sumPositive, sumNegative As Double
            Dim positiveFlag, negativeFlag As Boolean
            positiveFlag = True
            negativeFlag = True
            sumPositive = 0
            sumNegative = 0

            Dim posBuy As Long
            posBuy = 5
            Do While posBuy < 18 And WS.Cells(1, posBuy).Value <> WS.Cells(i, 20).Value
                posBuy = posBuy + 1
            Loop
            If (posBuy < 18) Then
                Dim j As Long
                For j = 5 To 17
                    If j = 6 Then j = j + 1
                    If IsEmpty(WS.Cells(i, j).Value) = False Then
                        If (WS.Cells(i, j).Value < 0) Then
                            If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
                                sumNegative = sumNegative - WS.Cells(i, j).Value * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
                            Else
                                negativeFlag = False
                            End If
                        End If
                        If (WS.Cells(i, j).Value > 0) Then
                            If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
                                sumPositive = sumPositive + WS.Cells(i, j).Value * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
                            Else
                                positiveFlag = False
                            End If
                        End If
                    End If
                Next j

                Dim cnt As Long
                cnt = 0
                Dim sum As Double
                sum = 0
                If positiveFlag Then
                    cnt = cnt + 1
                    sum = sum + sumPositive
                End If
                If negativeFlag Then
                    cnt = cnt + 1
                    sum = sum + sumNegative
                End If
                If (cnt <> 0) Then
                    If dealType(i) = "Buy" Then
                        If positiveFlag Then
                            sum = sumPositive
                            cnt = 1
                        End If
                        WS.Cells(i, 24).Value = (sum / cnt) / dealBuySum(WS.Cells(i, 22).Value) * WS.Cells(i, 23).Value / 10#
                        'If (WS.Cells(i, 24).Value > DoubleAbs(WS.Cells(i, 19).Value)) Then WS.Cells(i, 24).Value = DoubleAbs(WS.Cells(i, 19).Value)
                        If (WS.Cells(i, 19).Value < 0 And WS.Cells(i, 24).Value > 0) Then WS.Cells(i, 24).Value = -WS.Cells(i, 24).Value
                    Else
                        If positiveFlag Then
                            sum = sumPositive
                            cnt = 1
                        End If
                        WS.Cells(i, 24).Value = (sum / cnt) / dealSellSum(WS.Cells(i, 22).Value) * WS.Cells(i, 23).Value / 10#
                        'If (WS.Cells(i, 24).Value > DoubleAbs(WS.Cells(i, 19).Value)) Then WS.Cells(i, 24).Value = DoubleAbs(WS.Cells(i, 19).Value)
                        If (WS.Cells(i, 19).Value < 0 And WS.Cells(i, 24).Value > 0) Then WS.Cells(i, 24).Value = -WS.Cells(i, 24).Value
                    End If
                Else
                    WS.Cells(i, 24).Value = "NO BONUS"
                End If
            End If
        End If
    Next i
End Sub
'Converts Total in RUB
Private Sub CalculateTotalIn(ByRef WS As Worksheet, ByVal toWhat As Long, ByVal resultLine As Long, ByVal totalLine As Long, ByRef ExchangeRate() As Double)
    Dim j As Long
    Dim sum As Double
    sum = 0
    For j = 5 To 17
        If j = 6 Then j = j + 1
        If IsEmpty(WS.Cells(totalLine, j).Value) = False And WS.Cells(totalLine, j).Value <> 0 Then
            If ExchangeRate(toWhat, j) <> -1 Then
                sum = sum + WS.Cells(totalLine, j).Value * ExchangeRate(toWhat, j)
            Else
                If ExchangeRate(7, j) <> -1 And ExchangeRate(toWhat, 7) <> -1 Then
                    sum = sum + WS.Cells(totalLine, j).Value * ExchangeRate(toWhat, 7) * ExchangeRate(7, j)
                End If
            End If
        Else
        End If
    Next j
    Dim cur As String
    cur = WS.Cells(1, toWhat).Value
    WS.Cells(resultLine, 4).Value = WS.Cells(totalLine, 4).Value & " in " & WS.Cells(1, toWhat).Value
    WS.Cells(resultLine, toWhat).Value = sum
End Sub


'Calculate array exchangeRate with contains exchange rates for some particular day
Private Sub RecalculateExchangeRates(ByRef WS As Worksheet, ByVal x As Long, ByRef ExchangeRate() As Double, Optional ByVal numberOfDays As Long = 1)
' ExchangeRate(i, j) = how many I you can buy for one J
    Dim sumI(13, 13), sumJ(13, 13), rubUsd As Double
    Dim i, j, k, cntRubUsd As Long

    For i = 0 To 12
        For j = 0 To 12
            sumI(i, j) = 0
            sumJ(i, j) = 0
        Next j
    Next i

    rubUsd = 0
    cntRubUsd = 0
    Do While numberOfDays > 0 And x <= numberOfExchanges
        If IsEmpty(WS.Cells(x, 19).Value) Then
            If IsEmpty(WS.Cells(x, 6).Value) = False Then
                rubUsd = rubUsd + WS.Cells(x, 6).Value
                cntRubUsd = cntRubUsd + 1
            End If
            Dim posSell As Long, posBuy As Long, cnt As Long
            posSell = 0
            posBuy = 0
            cnt = 0
            For j = 5 To 17
                If j = 6 Then j = j + 1
                If WS.Cells(x, j).Value <> 0 Then
                    cnt = cnt + 1
                    If WS.Cells(x, j).Value < 0 Then
                        posSell = j
                    Else
                        posBuy = j
                    End If
                End If
            Next j
            If (cnt = 2 And posSell <> 0 And posBuy <> 0) Then
                sumI(posSell, posBuy) = sumI(posSell, posBuy) + DoubleAbs(WS.Cells(x, posSell).Value)
                sumJ(posSell, posBuy) = sumJ(posSell, posBuy) + DoubleAbs(WS.Cells(x, posBuy).Value)
                sumI(posBuy, posSell) = sumI(posBuy, posSell) + DoubleAbs(WS.Cells(x, posBuy).Value)
                sumJ(posBuy, posSell) = sumJ(posBuy, posSell) + DoubleAbs(WS.Cells(x, posSell).Value)
            End If
        End If
        If WS.Cells(x + 1, 2).Value <> WS.Cells(x, 2).Value Then numberOfDays = numberOfDays - 1
        x = x + 1
    Loop
    For i = 5 To 17
        If i = 6 Then i = i + 1
        For j = 5 To 17
            If j = 6 Then j = j + 1
            If i = j Then ExchangeRate(i, j) = 1
            If sumJ(i, j) <> 0 Then
                ExchangeRate(i, j) = sumI(i, j) / sumJ(i, j)
            End If
        Next j
    Next i
    If sumJ(5, 7) <> 0 Then
        rubUsd = rubUsd + sumI(5, 7) / sumJ(5, 7)
        cntRubUsd = cntRubUsd + 1
    End If
    If cntRubUsd <> 0 Then
        ExchangeRate(5, 7) = rubUsd / cntRubUsd
        ExchangeRate(7, 5) = cntRubUsd / rubUsd
    End If
End Sub

'The main function to calculate profit
'Makes matches between exchanges
Private Sub SuperDuper(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef ansector() As Long, ByRef sz() As Long, ByRef exchangeOveralCirculation() As Double)
    Dim i As Long, j As Long, k As Long
    Dim allBuy(5 To 17, 5 To 17, 2000) As Long
    Dim allBuySize(5 To 17, 5 To 17) As Long
    Dim allSell(5 To 17, 5 To 17, 2000) As Long
    Dim allSellSize(5 To 17, 5 To 17) As Long
    For i = 5 To 17
        For j = 5 To 17
            allBuySize(i, j) = 0
            allSellSize(i, j) = 0
        Next j
    Next i
    Dim magicalPercent As Double
    magicalPercent = 0.017
    For i = 3 To Rows.Count
        If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
        Dim ii As Long
        ii = i
        If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If
        i = ii
        If IsEmpty(WS.Cells(i, 22).Value) = False And IsEmpty(WS.Cells(i, 20).Value) = True Then
            Dim posSell As Long, posBuy As Long, cnt As Long
            posSell = 0
            posBuy = 0
            cnt = 0
            For j = 5 To 17
                If j = 6 Then j = j + 1
                If WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False Then
                    cnt = cnt + 1
                    If WS.Cells(i, j).Value < 0 Then
                        posSell = j
                    Else
                        posBuy = j
                    End If
                End If
            Next j
            If (posSell = 0 Or posBuy = 0) Then
                Dim sum As Double
                sum = 0
                For j = 5 To 17
                    If j = 6 Then j = j + 1
                    If WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False And getExchangeRate(WS, i, 7, j, ExchangeRate) <> -1 Then
                        sum = sum + WS.Cells(i, j).Value * getExchangeRate(WS, i, 7, j, ExchangeRate)
                    End If
                Next j
                WS.Cells(i, 19).Value = sum
                WS.Cells(i, 20).Value = WS.Cells(1, 7).Value
                cnt = 0
            End If
            If cnt = 2 Then
                Dim cntDays As Long, last As Long
                cntDays = 5
                last = -1
                If WS.Cells(i, 22).Value = "Buy" Then
                    Dim curExchangeRate As Double, pastExchangeRate As Double
                    If WS.Cells(i, posBuy).Value <> 0 Then
                        curExchangeRate = -WS.Cells(i, posSell).Value / WS.Cells(i, posBuy).Value
                        last = i
                        For j = allSellSize(posBuy, posSell) - 1 To 0 Step -1
                            If j < allBuySize(posBuy, posSell) - 50 Then Exit For
                        'For j = 0 To allBuySize(posBuy, posSell) - 1
                            k = allSell(posBuy, posSell, j)
                            If WS.Cells(k, 2).Value <> WS.Cells(last, 2).Value Then cntDays = cntDays - 1
                            If cntDays = 0 Then Exit For
                            last = k
                            If WS.Cells(k, posBuy).Value <> 0 Then
                                pastExchangeRate = -WS.Cells(k, posSell).Value / WS.Cells(k, posBuy).Value
                                If pastExchangeRate > curExchangeRate Then
                                    Dim componentNumber As Long
                                    'WS.Cells(cur, 21).Value = pr
                                    'WS.Cells(pr, 21).Value = cur
                                    Dim add As Double, Amount As Double
                                    Amount = Min(WS.Cells(i, posBuy).Value, -WS.Cells(k, posBuy).Value)
                                    add = (pastExchangeRate - curExchangeRate) * Amount
                                    If DoubleAbs(Amount) * getExchangeRate(WS, i, 7, posBuy, ExchangeRate) / (Min(exchangeOveralCirculation(i), exchangeOveralCirculation(k)) / 2) > magicalPercent And sz(getInDSU(ansector, k)) + sz(getInDSU(ansector, i)) <= 15 Then
                                        componentNumber = uniteInDsu(ansector, sz, k, i)
                                    End If

                                    WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + Amount
                                    WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - Amount * pastExchangeRate
                                    WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - Amount
                                    WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + Amount * curExchangeRate

                                    WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
                                    WS.Cells(i, 20).Value = WS.Cells(1, posSell).Value
                                    WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
                                    WS.Cells(k, 20).Value = WS.Cells(i, 20).Value

                                    'If IsEmpty(WS.Cells(i, 25).Value) Then WS.Cells(i, 25).Value = 0
                                    'If IsEmpty(WS.Cells(k, 25).Value) Then WS.Cells(k, 25).Value = 0
                                    'WS.Cells(i, 25).Value = WS.Cells(i, 25).Value + add / 2
                                    'WS.Cells(k, 25).Value = WS.Cells(k, 25).Value + add / 2
                                End If
                            End If
                        Next j
'                        For j = allSellSize(posBuy, posSell) - 1 To 0 Step -1
'                        'For j = 0 To allBuySize(posBuy, posSell) - 1
'                            k = allSell(posBuy, posSell, j)
'                            If WS.Cells(k, posBuy).Value <> 0 Then
'                                pastExchangeRate = -WS.Cells(k, posSell).Value / WS.Cells(k, posBuy).Value
'                                If True Then
'                                    'WS.Cells(cur, 21).Value = pr
'                                    'WS.Cells(pr, 21).Value = cur
'                                    amount = Min(WS.Cells(i, posBuy).Value, -WS.Cells(k, posBuy).Value)
'                                    add = (pastExchangeRate - curExchangeRate) * amount
'
'                                    WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + amount
'                                    WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - amount * pastExchangeRate
'                                    WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - amount
'                                    WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + amount * curExchangeRate
'
'                                    WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
'                                    WS.Cells(i, 20).Value = WS.Cells(1, posSell).Value
'                                    WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
'                                    WS.Cells(k, 20).Value = WS.Cells(i, 20).Value
'                                End If
'                            End If
'                        Next j
                    End If
                    '-----------------------------------------------------------------
                    allBuy(posSell, posBuy, allBuySize(posSell, posBuy)) = i
                    allBuySize(posSell, posBuy) = allBuySize(posSell, posBuy) + 1
                Else 'WS.Cells(i, 22).Value = "Sell"
                    If WS.Cells(i, posSell).Value <> 0 Then
                        curExchangeRate = -WS.Cells(i, posBuy).Value / WS.Cells(i, posSell).Value
                        last = i
                        For j = allBuySize(posBuy, posSell) - 1 To 0 Step -1
                            If j < allBuySize(posBuy, posSell) - 50 Then Exit For
                        'For j = 0 To allBuySize(posBuy, posSell) - 1
                            k = allBuy(posBuy, posSell, j)
                            If WS.Cells(k, 2).Value <> WS.Cells(last, 2).Value Then cntDays = cntDays - 1
                            If cntDays = 0 Then Exit For
                            last = k
                            If WS.Cells(k, posSell).Value <> 0 Then
                                pastExchangeRate = -WS.Cells(k, posBuy).Value / WS.Cells(k, posSell).Value
                                If pastExchangeRate < curExchangeRate Then
                                    'WS.Cells(cur, 21).Value = pr
                                    'WS.Cells(pr, 21).Value = cur
                                    Amount = Min(-WS.Cells(i, posSell).Value, WS.Cells(k, posSell).Value)
                                    add = (curExchangeRate - pastExchangeRate) * Amount
                                    If DoubleAbs(Amount) * getExchangeRate(WS, i, 7, posBuy, ExchangeRate) / Min(exchangeOveralCirculation(i), exchangeOveralCirculation(k)) > magicalPercent And sz(getInDSU(ansector, k)) + sz(getInDSU(ansector, i)) <= 15 Then
                                        componentNumber = uniteInDsu(ansector, sz, k, i)
                                    End If

                                    WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + Amount * pastExchangeRate
                                    WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - Amount
                                    WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - Amount * curExchangeRate
                                    WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + Amount

                                    WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
                                    WS.Cells(i, 20).Value = WS.Cells(1, posBuy).Value
                                    WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
                                    WS.Cells(k, 20).Value = WS.Cells(i, 20).Value

                                    'If IsEmpty(WS.Cells(i, 25).Value) Then WS.Cells(i, 25).Value = 0
                                    'If IsEmpty(WS.Cells(k, 25).Value) Then WS.Cells(k, 25).Value = 0
                                    'WS.Cells(i, 25).Value = WS.Cells(i, 25).Value + add / 2
                                    'WS.Cells(k, 25).Value = WS.Cells(k, 25).Value + add / 2
                                End If
                            End If
                        Next j
                        last = i
                        For j = allBuySize(posBuy, posSell) - 1 To 0 Step -1
                            If j < allBuySize(posBuy, posSell) - 50 Then Exit For
                            k = allBuy(posBuy, posSell, j)
                            If WS.Cells(k, 2).Value <> WS.Cells(last, 2).Value Then cntDays = cntDays - 1
                            If cntDays = 0 Then Exit For
                            last = k
                            If WS.Cells(k, posSell).Value <> 0 Then
                                pastExchangeRate = -WS.Cells(k, posBuy).Value / WS.Cells(k, posSell).Value
                                If True Then
                                    'WS.Cells(cur, 21).Value = pr
                                    'WS.Cells(pr, 21).Value = cur
                                    'Dim add As Double, amount As Double
                                    Amount = Min(-WS.Cells(i, posSell).Value, WS.Cells(k, posSell).Value)
                                    add = (curExchangeRate - pastExchangeRate) * Amount
                                    If DoubleAbs(Amount) * getExchangeRate(WS, i, 7, posBuy, ExchangeRate) / Min(exchangeOveralCirculation(i), exchangeOveralCirculation(k)) > magicalPercent And sz(getInDSU(ansector, k)) + sz(getInDSU(ansector, i)) <= 15 Then
                                        componentNumber = uniteInDsu(ansector, sz, k, i)
                                    End If

                                    WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + Amount * pastExchangeRate
                                    WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - Amount
                                    WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - Amount * curExchangeRate
                                    WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + Amount

                                    WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
                                    WS.Cells(i, 20).Value = WS.Cells(1, posBuy).Value
                                    WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
                                    WS.Cells(k, 20).Value = WS.Cells(i, 20).Value

                                    'If IsEmpty(WS.Cells(i, 25).Value) Then WS.Cells(i, 25).Value = 0
                                    'If IsEmpty(WS.Cells(k, 25).Value) Then WS.Cells(k, 25).Value = 0
                                    'WS.Cells(i, 25).Value = WS.Cells(i, 25).Value + add / 2
                                    'WS.Cells(k, 25).Value = WS.Cells(k, 25).Value + add / 2
                                End If
                            End If
                        Next j
                    End If
                    '---------------------------
                    allSell(posSell, posBuy, allSellSize(posSell, posBuy)) = i
                    allSellSize(posSell, posBuy) = allSellSize(posSell, posBuy) + 1
                End If
            End If
        End If
    Next i
    'MsgBox "SuperDuper"
End Sub

'Some editional matching for exchanges
'It work perfectly with exchanges that are almost equal
Private Sub DeleteEqual(ByRef WS As Worksheet, ByRef ansector() As Long, ByRef sz() As Long, ByRef ExchangeRate() As Double)
    Dim i As Long, lastDay As Long
    lastDay = 2
    Call RecalculateExchangeRates(WS, 3, ExchangeRate)
    For i = 3 To Rows.Count
        If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
        Dim last As Long
        last = i
        Do While WS.Cells(last, 2).Value = WS.Cells(last + 1, 2).Value
            last = last + 1
        Loop
        Dim ii As Long
        ii = i
        If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If
        i = ii
        Dim cur As Long, pr As Long, j As Long
        For cur = i To last
'               Check just the same lines
            For pr = lastDay To cur - 1
                If IsEmpty(WS.Cells(pr, 21).Value) Then
                    Dim cnt As Long, pos As Long
                    cnt = 0
                    pos = 5
                    For j = 5 To 17
                        If j = 6 Then j = j + 1
                        If IsEmpty(WS.Cells(cur, j).Value) <> IsEmpty(WS.Cells(pr, j).Value) Then
                            cnt = 228
                            Exit For
                        End If
                        If IsEmpty(WS.Cells(cur, j).Value) = False Then
                            If WS.Cells(cur, j).Value + WS.Cells(pr, j).Value <> 0 Then
                                cnt = cnt + 1
                                pos = j
                            End If
                        End If
                    Next j
                    If cnt = 0 Then
                        Dim componentNumber As Long
                        componentNumber = uniteInDsu(ansector, sz, pr, cur)
                        WS.Cells(cur, 21).Value = pr
                        WS.Cells(pr, 21).Value = cur
                        WS.Cells(cur, 19).Value = 0
                        WS.Cells(cur, 20).Value = WS.Cells(1, pos).Value
                        WS.Cells(pr, 19).Value = WS.Cells(cur, 19).Value
                        WS.Cells(pr, 20).Value = WS.Cells(cur, 20).Value
                        'If IsEmpty(WS.Cells(cur, 25).Value) Then WS.Cells(cur, 25).Value = 0
                        'If IsEmpty(WS.Cells(pr, 25).Value) Then WS.Cells(pr, 25).Value = 0
                        'WS.Cells(cur, 25).Value = WS.Cells(cur, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
                        'WS.Cells(pr, 25).Value = WS.Cells(pr, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
                        For j = 5 To 17
                            If j = 6 Then j = j + 1
                            If IsEmpty(WS.Cells(cur, j).Value) = False Then
                                WS.Cells(cur, j).Value = ""
                            End If
                            If IsEmpty(WS.Cells(pr, j).Value) = False Then
                                WS.Cells(pr, j).Value = ""
                            End If
                        Next j
                        Exit For
                    End If
                    If cnt = 1 Then
                        componentNumber = uniteInDsu(ansector, sz, pr, cur)
                        WS.Cells(cur, 21).Value = pr
                        WS.Cells(pr, 21).Value = cur
                        WS.Cells(cur, 19).Value = WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value
                        WS.Cells(cur, 20).Value = WS.Cells(1, pos).Value
                        WS.Cells(pr, 19).Value = WS.Cells(cur, 19).Value
                        WS.Cells(pr, 20).Value = WS.Cells(cur, 20).Value
                        'If IsEmpty(WS.Cells(cur, 25).Value) Then WS.Cells(cur, 25).Value = 0
                        'If IsEmpty(WS.Cells(pr, 25).Value) Then WS.Cells(pr, 25).Value = 0
                        'WS.Cells(cur, 25).Value = WS.Cells(cur, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
                        'WS.Cells(pr, 25).Value = WS.Cells(pr, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
                        For j = 5 To 17
                            If j = 6 Then j = j + 1
                            If IsEmpty(WS.Cells(cur, j).Value) = False Then
                                WS.Cells(cur, j).Value = ""
                            End If
                            If IsEmpty(WS.Cells(pr, j).Value) = False Then
                                WS.Cells(pr, j).Value = ""
                            End If
                        Next j

                        Exit For
                    End If
                End If
            Next pr
        Next cur
        lastDay = i
        i = last
    Next i
    'MsgBox "DeleteEqual"
End Sub

'Remained currencies just summarize to the profit of exchange
Private Sub AddRest(ByRef WS As Worksheet, ByRef ExchangeRate() As Double)
    For i = 3 To Rows.Count
        If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
        Dim ii As Long
        ii = i
        If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If
        i = ii

        Dim f As Boolean
        f = True
        If IsEmpty(WS.Cells(i, 19).Value) = True Then
            WS.Cells(i, 19).Value = 0
            WS.Cells(i, 20).Value = WS.Cells(1, 7).Value
        Else
            j = 5
            Do While WS.Cells(1, j).Value <> WS.Cells(i, 20).Value
                j = j + 1
            Loop
            If (getExchangeRate(WS, i, 7, j, ExchangeRate) = -1) Then
                f = False
            Else
                WS.Cells(i, 19).Value = WS.Cells(i, 19).Value * getExchangeRate(WS, i, 7, j, ExchangeRate)
                WS.Cells(i, 20).Value = WS.Cells(1, 7).Value
            End If
        End If
        For j = 5 To 17
            If j = 6 Then j = j + 1
            If WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False Then
                If (ExchangeRate(7, j) = -1) Then f = False
            End If
        Next j
        For j = 5 To 17
            If j = 6 Then j = j + 1
            If f And WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False Then
                WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + WS.Cells(i, j) * ExchangeRate(7, j)
            End If
        Next j
    Next i
End Sub

Private Function getExchangeRate(ByRef WS As Worksheet, ByVal i As Long, ByVal x As Long, ByVal y As Long, ByRef ExchangeRate() As Double) As Double
    getExchangeRate = ExchangeRate(x, y)
    If IsEmpty(WS.Cells(i, 6).Value) = False Then
        If x = 5 And y = 7 Then getExchangeRate = WS.Cells(i, 6).Value
        If x = 7 And y = 5 Then getExchangeRate = 1# / WS.Cells(i, 6).Value
    End If
End Function

Private Sub CalculateExchangeOveralCirculation(ByRef WS As Worksheet, ByRef exchangeOveralCirculation() As Double, ByRef ExchangeRate() As Double)
    Dim i As Long
    For i = 3 To WS.Rows.Count
        If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
        If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If
        Dim j As Long
        For j = 5 To 17
            If j = 6 Then j = 7
            If IsEmpty(WS.Cells(i, j).Value) = False And getExchangeRate(WS, i, 7, j, ExchangeRate) <> -1 Then
                exchangeOveralCirculation(i) = exchangeOveralCirculation(i) + DoubleAbs(WS.Cells(i, j).Value) * getExchangeRate(WS, i, 7, j, ExchangeRate)
            End If
        Next j
    Next i
End Sub


'Cells(i, 21) = "Sell" or "Buy", if we by crypto, then it is "Buy", otherwise it is "Sell"
Private Sub DetermineDealType(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef dealType() As String)
    Dim i As Long, j As Long
    Dim posSell As Long, posBuy As Long, cnt As Long
    Dim f As Boolean

    Call RecalculateExchangeRates(WS, 1, ExchangeRate, 3)
    For i = 1 To numberOfExchanges
        If i > 1 And exchanges(i).Day <> exchanges(i - 1).Day Then
            Call RecalculateExchangeRates(WS, i, ExchangeRate)
        End If

        If exchanges(i).CurrencyNumber <> 0 Then
            If True Then
                If exchanges(i).Amount(1) < 0 And exchanges(i).Amount(2) <= 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
                    exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
                    exchanges(i).Amount(1) = 0
                End If
                If exchanges(i).Amount(1) <> 0 And exchanges(i).Amount(2) <> 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
                    If (DoubleAbs((exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)) / exchanges(i).Amount(2)) < 0.1) Then
                        exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
                        exchanges(i).Amount(1) = 0
                    End If
                End If
                If exchanges(i).Amount(1) <> 0 And exchanges(i).Amount(2) <> 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
                    f = False
                    For j = 3 To 12
                        If exchanges(i).Amount(j) <> 0 Then f = True
                    Next j
                    If f Then
                        exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
                        exchanges(i).Amount(1) = 0
                    End If
                End If
                If exchanges(i).Amount(1) > 0 And exchanges(i).Amount(2) >= 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
                    exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
                    exchanges(i).Amount(1) = 0
                End If
            End If
            posSell = 0
            posBuy = 0
            cnt = 0
            For j = 1 To 12
                If exchanges(i).Amount(j) <> 0 Then
                    cnt = cnt + 1
                    If exchanges(i).Amount(j) < 0 Then
                        posSell = j
                    Else
                        posBuy = j
                    End If
                End If
            Next j

            If exchanges(i).Amount(1) = 0 And exchanges(i).Amount(3) <> 0 And (cnt <> 2 Or (cnt = 2 And exchanges(i).Amount(2) = 0)) Then
                If getExchangeRate(WS, i, 2, 3, ExchangeRate) <> -1 Then
                    exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(3) * getExchangeRate(WS, i, 2, 3, ExchangeRate)
                    exchanges(i).Amount(3) = 0
                End If
            End If
            If cnt <> 2 Then
                posSell = 0
                posBuy = 0
                cnt = 0
                For j = 1 To 12
                    If exchanges(i).Amount(j) <> 0 Then
                        cnt = cnt + 1
                        If exchanges(i).Amount(j) < 0 Then
                            posSell = j
                        Else
                            posBuy = j
                        End If
                    End If
                Next j
            End If
            If cnt = 2 Then
                If posSell > 7 And posBuy > 7 Then
                    If posSell = 8 Or posSell = 14 Or posSell = 16 Then
                        exchanges(i).BuyOrSell = "Buy"
                        dealType(i) = "Buy"
                    Else
                        exchanges(i).BuyOrSell = "Sell"
                        dealType(i) = "Sell"
                    End If
                Else
                    If posSell <= 7 And posBuy <= 7 Then
                        If posSell = 5 Then
                            exchanges(i).BuyOrSell = "Buy"
                            dealType(i) = "Buy"
                        Else
                            exchanges(i).BuyOrSell = "Sell"
                            dealType(i) = "Sell"
                        End If
                    Else
                        If posSell = 5 Or posSell = 7 Then
                            exchanges(i).BuyOrSell = "Buy"
                            dealType(i) = "Buy"
                        Else
                            exchanges(i).BuyOrSell = "Sell"
                            dealType(i) = "Sell"
                        End If
                    End If
                End If
            End If
        End If
    Next i
End Sub

'Function that controls calls of auxiliary functions
'The result of evaluation is calculated profits and perfect look of the table
Private Sub CalculateProfit(ByRef WS As Worksheet, ByVal buttonName As String)
    Dim i, j, numberOfLines As Long
    numberOfLines = calculateNumberOfLines(WS)
    Dim ansectorInDSU(5000), sz(5000) As Long
    Dim ExchangeRate(13, 13), sumOfProfit(5000), dealBuySum(5000), dealSellSum(5000), exchangeOveralCirculation(5000) As Double
    Dim dealType(5000) As String


    For i = 0 To numberOfExchanges
        sumOfProfit(i) = 0
        dealBuySum(i) = 0
        dealSellSum(i) = 0
        ansectorInDSU(i) = i
        sz(i) = 1
        exchangeOveralCirculation(i) = 0
    Next i

    For i = 1 To 12
        For j = 1 To 12
            ExchangeRate(i, j) = -1
        Next j
    Next i
    Call DetermineDealType(WS, ExchangeRate, dealType)

    For i = 1 To 12
        For j = 1 To 12
            ExchangeRate(i, j) = -1
        Next j
    Next i
    Call DeleteEqual(WS, ansectorInDSU, sz, ExchangeRate)
    Call CalculateExchangeOveralCirculation(WS, exchangeOveralCirculation, ExchangeRate)
    For i = 1 To 12
        For j = 1 To 12
            ExchangeRate(i, j) = -1
        Next j
    Next i
    Call SuperDuper(WS, ExchangeRate, ansectorInDSU, sz, exchangeOveralCirculation)
    Call AddRest(WS, ExchangeRate)
    Call Init(WS, False, buttonName)
    Call LeaveOnlyMarked(WS)
    Call CalculateSummary(WS, ExchangeRate)

    For i = 3 To numberOfLines
        WS.Cells(i, 21).Value = WS.Cells(i, 22).Value
        WS.Cells(i, 22).Value = getInDSU(ansectorInDSU, i)
    Next i
    Call calculateSumOfProfit(WS, ExchangeRate, sumOfProfit)
    For i = 3 To numberOfLines
        If IsEmpty(WS.Cells(i, 22).Value) = False Then
            WS.Cells(i, 23).Value = sumOfProfit(WS.Cells(i, 22).Value)
        End If
    Next i
    Call calculateDealSum(WS, ExchangeRate, dealBuySum, dealSellSum, dealType)
    Call calculateBonusWithDealSum(WS, ExchangeRate, dealBuySum, dealSellSum, dealType)
    WS.Cells(1, 18).Value = "Ïðîôèò îïåðàöèè"
    WS.Cells(1, 19).Value = "Âàëþòà"
    WS.Cells(1, 20).Value = "% ïðîôèòà"
    WS.Cells(1, 21).Value = "¹ ñäåëêè"
    WS.Cells(1, 22).Value = "Ïðîôèò ñäåëêè"
    WS.Cells(1, 23).Value = "Áîíóñ"
    WS.Cells(1, 24).Value = "Àâòîð"
    For i = 1 To numberOfLines
        For j = 1 To 24
            WS.Cells(i, j).Borders.LineStyle = xlContinuous
        Next j
    Next i
    For i = 3 To numberOfLines
        Dim operationProfit As Double
        operationProfit = WS.Cells(i, 19).Value
        Dim currentCurrency As String
        currentCurrency = WS.Cells(i, 20).Value
        Dim person As String
        person = WS.Cells(i, 18).Value
        Dim ProfitPercentage As Double
        ProfitPercentage = WS.Cells(i, 21).Value
        Dim id As Long
        id = WS.Cells(i, 22).Value
        Dim sumOfDeal As Double
        sumOfDeal = WS.Cells(i, 23).Value
        Dim bonus As Double
        bonus = WS.Cells(i, 24).Value

        For j = 18 To 24
            WS.Cells(i, j).ClearContents
        Next j
        WS.Cells(i, 18).Value = CDbl(operationProfit)
        WS.Cells(i, 18).NumberFormat = "0.00"
        WS.Cells(i, 19).Value = currentCurrency
        WS.Cells(i, 20).Value = CDbl(ProfitPercentage)
        WS.Cells(i, 20).NumberFormat = "0.00"
        WS.Cells(i, 21).Value = id
        WS.Cells(i, 22).Value = CDbl(sumOfDeal)
        WS.Cells(i, 22).NumberFormat = "0.00"
        WS.Cells(i, 23).Value = CDbl(bonus)
        WS.Cells(i, 23).NumberFormat = "0.00"
        WS.Cells(i, 24).Value = person
    Next i

    Dim lastLine As Long
    lastLine = printBonus(WS)

    Dim used(5000) As Boolean, sumOverDeals(20) As Double
    For i = 4 To 17
        sumOverDeals(i) = 0
    Next i
    For i = 3 To numberOfLines
        If (WS.Cells(i, 24).Value = "ë" And used(WS.Cells(i, 21).Value) = False) Then
            used(WS.Cells(i, 21).Value) = True
            For j = 5 To 17
                If (WS.Cells(1, j).Value = WS.Cells(i, 19).Value) Then
                    sumOverDeals(j) = sumOverDeals(j) + WS.Cells(i, 22).Value
                End If
            Next j
        End If
    Next i

    WS.Cells(lastLine + 1, 4).Value = "Ïðèáûëü ïî ñäåëêàì ñ ó÷àñòèåì Ë"
    For j = 5 To 17
        WS.Cells(lastLine + 1, j).Value = sumOverDeals(j)
    Next j
    For j = 4 To 17
        WS.Cells(lastLine + 1, j).Interior.Color = vbYellow
    Next j

    For i = 4 To 17
        sumOverDeals(i) = 0
    Next i
    For i = 3 To numberOfLines
        If (WS.Cells(i, 24).Value = "þ" And used(WS.Cells(i, 21).Value) = True) Then
            used(WS.Cells(i, 21).Value) = False
            For j = 5 To 17
                If (WS.Cells(1, j).Value = WS.Cells(i, 19).Value) Then
                    sumOverDeals(j) = sumOverDeals(j) + WS.Cells(i, 22).Value
                End If
            Next j
        End If
    Next i

    WS.Cells(lastLine + 2, 4).Value = "Ïðèáûëü ïî ñäåëêàì ñ ó÷àñòèåì Þ"
    For j = 5 To 17
        WS.Cells(lastLine + 2, j).Value = sumOverDeals(j)
    Next j
    For j = 4 To 17
        WS.Cells(lastLine + 2, j).Interior.Color = RGB(255, 120, 200)
    Next j

    Dim firstLine As Long
    firstLine = lastLine
    Do While IsEmpty(WS.Cells(firstLine - 1, 4).Value) = False
        firstLine = firstLine - 1
    Loop
    Do While IsEmpty(WS.Cells(lastLine + 1, 4).Value) = False
        lastLine = lastLine + 1
    Loop
    For i = firstLine To lastLine - 1
        If (WS.Cells(i, 4).Interior.Color <> WS.Cells(i + 1, 4).Interior.Color) Then
            For j = i + 1 To lastLine
                If (WS.Cells(i, 4).Interior.Color = WS.Cells(j, 4).Interior.Color) Then
                    Do While j <> i + 1
                        Dim k As Long
                        For k = 4 To 17
                            WS.Cells(firstLine, 3).Value = WS.Cells(j - 1, k).Value
                            WS.Cells(j - 1, k).Value = WS.Cells(j, k).Value
                            WS.Cells(j, k).Value = WS.Cells(firstLine, 3).Value
                            WS.Cells(firstLine, 3).NumberFormat = WS.Cells(j - 1, k).NumberFormat
                            WS.Cells(j - 1, k).NumberFormat = WS.Cells(j, k).NumberFormat
                            WS.Cells(j, k).NumberFormat = WS.Cells(firstLine, 3).NumberFormat
                            WS.Cells(firstLine, 3).Interior.Color = WS.Cells(j - 1, k).Interior.Color
                            WS.Cells(j - 1, k).Interior.Color = WS.Cells(j, k).Interior.Color
                            WS.Cells(j, k).Interior.Color = WS.Cells(firstLine, 3).Interior.Color
                        Next k
                        j = j - 1
                    Loop
                    Exit For
                End If
            Next j
        End If
    Next i
    WS.Cells(firstLine, 3).Value = ""
    WS.Cells(firstLine, 3).Interior.Color = vbWhite
    'MsgBox numberOfLines
    numberOfLines = numberOfLines + 32
    If buttonName = "Daily revenue" Then
        For i = 3 To numberOfLines
            For j = 1 To 24
                Call swapCells(WS, i, j, 3 * numberOfLines + i, j)
            Next j
        Next i
        j = 2
        For i = 3 To numberOfLines
            If i <> 3 And WS.Cells(3 * numberOfLines + i, 2).Value <> WS.Cells(j, 2).Value Then
                j = j + 3
            Else
                j = j + 1
            End If
            For k = 1 To 24
                Call swapCells(WS, 3 * numberOfLines + i, k, j, k)
            Next k
        Next i
        For i = 3 To numberOfLines * 3
            If IsEmpty(WS.Cells(i, 1).Value) = False Then
                Call RecalculateExchangeRates(WS, i, ExchangeRate)
                j = i
                Do While IsEmpty(WS.Cells(j + 1, 1).Value) = False
                    j = j + 1
                Loop
                WS.Cells(j + 1, 4).Value = "Sum in USD"
                WS.Cells(j + 1, 7).Value = 0#
                WS.Cells(j + 2, 4).Value = "Total profit in USD"
                WS.Cells(j + 2, 7).Value = 0#
                For k = i To j
                    Dim p As Long
                    If IsEmpty(WS.Cells(k, 18).Value) = False Then
                        For p = 5 To 17
                            If WS.Cells(1, p).Value = WS.Cells(k, 19).Value Then
                                WS.Cells(j + 2, 7).Value = WS.Cells(j + 2, 7).Value + WS.Cells(k, 18).Value * getExchangeRate(WS, k, 7, p, ExchangeRate)
                            End If
                        Next p
                    End If
                    For p = 5 To 17
                        If p = 6 Then p = 7
                        If IsEmpty(WS.Cells(k, p).Value) = False Then
                            WS.Cells(j + 1, 7).Value = WS.Cells(j + 1, 7).Value + WS.Cells(k, p).Value * getExchangeRate(WS, k, 7, p, ExchangeRate)
                        End If
                    Next p
                Next k
                i = j
            End If
        Next i
    End If
End Sub

Private Sub swapCells(ByRef WS As Worksheet, ByVal i As Long, ByVal j As Long, ByVal iTo As Long, ByVal jTo As Long)
    WS.Cells(1, 50).Value = WS.Cells(i, j).Value
    WS.Cells(1, 50).Interior.Color = WS.Cells(i, j).Interior.Color
    WS.Cells(1, 50).NumberFormat = WS.Cells(i, j).NumberFormat
    WS.Cells(1, 50).Borders.LineStyle = WS.Cells(i, j).Borders.LineStyle

    WS.Cells(i, j).Value = WS.Cells(iTo, jTo).Value
    WS.Cells(i, j).Interior.Color = WS.Cells(iTo, jTo).Interior.Color
    WS.Cells(i, j).NumberFormat = WS.Cells(iTo, jTo).NumberFormat
    WS.Cells(i, j).Borders.LineStyle = WS.Cells(iTo, jTo).Borders.LineStyle

    WS.Cells(iTo, jTo).Value = WS.Cells(1, 50).Value
    WS.Cells(iTo, jTo).Interior.Color = WS.Cells(1, 50).Interior.Color
    WS.Cells(iTo, jTo).NumberFormat = WS.Cells(1, 50).NumberFormat
    WS.Cells(iTo, jTo).Borders.LineStyle = WS.Cells(1, 50).Borders.LineStyle

    'WS.Cells(1, 50).clear
End Sub