SHARE
TWEET

Untitled

a guest Sep 18th, 2019 132 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. 'v.1.1.20
  2. 'Code is totally rewriten.
  3. 'Increased speed of calculation.
  4.  
  5. Sub CalculateBonusMacros()
  6.     Application.ScreenUpdating = False
  7.     Dim WS As Worksheet
  8.     'If Init(WS, True, "Bonus") Then
  9.    '    End Sub
  10.    '    Call CalculateProfit(WS, "Bonus")
  11.    'End If
  12.    Application.ScreenUpdating = True
  13. End Sub
  14.  
  15. Sub CalculateDailyRevenueMacros()
  16.     Application.ScreenUpdating = False
  17.     Dim WS As Worksheet
  18.     If Init(WS, True, "Daily revenue") Then
  19.         Call CalculateProfit(WS, "Daily revenue")
  20.     End If
  21.     Application.ScreenUpdating = True
  22. End Sub
  23. '_________________________________________________________________________________________________________________________________________________
  24.  
  25. Private Type Manager
  26.     Dim NickName As String
  27.     Dim RealName As String
  28.     Dim City As String
  29. End Sub
  30.  
  31. Private Type Exchange
  32.     Dim ExchangeType As String
  33.     Dim Day As String
  34.     Dim ProjectName As String
  35.     Dim Description As String
  36.     Dim Amount(17) As Double
  37.     Dim ExchangeRate As Double
  38.     Dim Manager As Long
  39.     Dim BuyOrSell As String
  40.     Dim Pair As Long
  41.     Dim Profit As Double
  42.     Dim CurrencyNumber As Long
  43.     Dim ProfitPercentage As Double
  44.     Dim DealNumber As Long
  45.     Dim Errors As String
  46. End Sub
  47.  
  48. Dim numberOfManagers, numberOfExchanges As Long
  49. Dim managers(4) As Manager
  50. Dim CurrencyNames(16), MonthToCalculate As String
  51. Dim exchanges() As Exchange
  52. Dim exchangesCopy() As Exchange
  53.  
  54. Function Inc(ByRef val As Variant, Optional ByVal add As Variant = 1) As Variant
  55.     val = val + add
  56.     Inc = val
  57. End Function
  58.  
  59. Sub InitManager(NickName As String, RealName As String, City As String)
  60.     Inc numberOfManagers
  61.     With Manager(numberOfManagers)
  62.         .NickName = NickName
  63.         .RealName = RealName
  64.         .City = City
  65.     End With
  66. End Sub
  67.  
  68. Function Init(ByRef WS As Worksheet, clear As Boolean, ByVal buttonName As String) As Boolean
  69.     Dim f As Boolean
  70.     Dim newSheetName, s As String
  71.     Dim i, j, k, cnt, cntNegative, cntPositive, cntErrors As Long
  72.    
  73.     Call InitManager("ë", "Ë", "Moscow")
  74.     Call InitManager("þ", "Þ", "Moscow")
  75.     Call InitManager("ï", "Ï", "Moscow")
  76.    
  77.     k = 1
  78.     For j = 5 To 17
  79.         If j = 6 Then j = 7
  80.         CurrencyNames(k) = Cells(1, j).Value
  81.         Inc k
  82.     Next j
  83.    
  84.     f = False
  85.     'Set the name of new sheet
  86.    If buttonName = "Bonus" Then
  87.         If IsEmpty(Cells(1, 18).Value) Then
  88.             MsgBox "Ââåäèòå ìåñÿö"
  89.             End
  90.         Else
  91.             newSheetName = "Bonus - " & Cells(1, 18).Value
  92.         End If
  93.     Else
  94.         If IsEmpty(Cells(1, 18).Value) Then
  95.             MsgBox "Ââåäèòå ìåñÿö"
  96.             End
  97.         Else
  98.             newSheetName = "Daily revenue - " & Cells(1, 18).Value
  99.         End If
  100.     End If
  101.     'If There is already sheet with such name, then don't create a new sheet ...
  102.    For Each it In Sheets
  103.         If it.Name = newSheetName Then
  104.             Set WS = it
  105.             f = True
  106.             If clear Then WS.Cells.clear
  107.         End If
  108.     Next it
  109.     '... but if there not such sheet, then create a new one
  110.    If f = False Then
  111.         s = ActiveSheet.Name
  112.         Set WS = Sheets.add
  113.         WS.Name = newSheetName
  114.         Worksheets(s).Activate
  115.     End If
  116.    
  117.     WS.Visible = True
  118.  
  119.     Range("A1:R1").Copy WS.Range("A1:R1")
  120.     Range("E2:R2").Copy WS.Range("E2:R2")
  121.    
  122.     Call DelButtons(WS)
  123.    
  124.     MonthToCalculate = Cells(1, 18).Value
  125.    
  126.    
  127.     'Copy exchanges from the month
  128.    j = 3
  129.     Do While IsEmpty(Cells(j, 1).Value) = False
  130.         j = j + 1
  131.     Loop
  132.     ReDim exchanges(j)
  133.    
  134.     numberOfExchanges = 0
  135.     For i = 3 To Rows.Count
  136.         If IsEmpty(Cells(i, 1).Value) Then
  137.             Exit For
  138.         End If
  139.         If GoodDay(Cells(i, 2).Value) = False Then Next i
  140.         If Cells(i, 1).Value = "îáìåí" And Cells(i, 4).Value <> "Íåó÷òåííûé äîõîä" And Cells(i, 4).Value <> "Íåó÷òåííûé ðàñõîä" And Cells(i, 1).Interior.Color <> vbRed Then
  141.             cnt = 0
  142.             cntPositive = 0
  143.             cntNegative = 0
  144.             For k = 5 To 17
  145.                 If k <> 6 And IsEmpty(Cells(i, k).Value) = False Then
  146.                     If Cells(i, k).Value <> 0 Then cnt = cnt + 1
  147.                     If Cells(i, k).Value > 0 Then cntPositive = cntPositive + 1
  148.                     If Cells(i, k).Value < 0 Then cntNegative = cntNegative + 1
  149.                 End If
  150.             Next k
  151.             If cnt >= 2 And cntPositive > 0 And cntNegative > 0 Then
  152.                 numberOfExchanges = numberOfExchanges + 1
  153.                 exchanges(numberOfExchanges).ExchangeType = WS.Cells(i, 1).Value
  154.                 exchanges(numberOfExchanges).Day = WS.Cells(i, 2).Value
  155.                 exchanges(numberOfExchanges).ProjectName = WS.Cells(i, 3).Value
  156.                 exchanges(numberOfExchanges).Description = WS.Cells(i, 4).Value
  157.                 If IsEmpty(WS.Cells(i, 6).Vlaue) Then
  158.                     exchanges(numberOfExchanges).ExchangeRate = -1
  159.                 Else
  160.                     exchanges(numberOfExchanges).ExchangeRate = WS.Cells(i, 6).Value
  161.                 End If
  162.                 k = 1
  163.                 For j = 5 To 17
  164.                     If j = 6 Then j = 7
  165.                     If IsEmpty(WS.Cells(i, j).Value) = False Then
  166.                         exchanges(numberOfExchanges).Amount(k) = WS.Cells(i, j).Value
  167.                     Else
  168.                         exchanges(numberOfExchanges).Amount(k) = 0
  169.                     End If
  170.                     k = k + 1
  171.                 Next j
  172.                 exchanges(numberOfExchanges).Manager = 0
  173.                 If IsEmpty(WS.Cells(i, 18).Value) = False Then
  174.                     For j = 1 To numberOfManagers
  175.                         If WS.Cells(i, 18).Value = Manager(j).NickName Then
  176.                             exchanges(numberOfExchanges).Manager = j
  177.                         End If
  178.                     Next j
  179.                 End If
  180.                 exchanges(numberOfExchanges).BuyOrSell = ""
  181.                 exchanges(numberOfExchanges).Pair = -1
  182.                 exchanges(numberOfExchanges).Profit = 0#
  183.                 exchanges(numberOfExchanges).CurrencyNumber = 0
  184.                 exchanges(numberOfExchanges).DealNumber = 0
  185.                 exchanges(numberOfExchanges).Errors = ""
  186.             End If
  187.         End If
  188.     Next i
  189.     WS.Cells(1, 1).EntireColumn.AutoFit
  190.     WS.Cells(1, 2).EntireColumn.AutoFit
  191.     WS.Cells(1, 3).EntireColumn.AutoFit
  192.     WS.Cells(1, 4).EntireColumn.AutoFit
  193.     WS.Cells(1, 5).EntireColumn.AutoFit
  194.     'MsgBox "Init"
  195. End Function
  196.  
  197. Private Function calculateNumberOfLines(ByRef WS As Worksheet) As Long
  198.     Dim answer As Long
  199.     answer = 2
  200.     Do While IsEmpty(WS.Cells(answer + 1, 1).Value) = False
  201.         answer = answer + 1
  202.     Loop
  203.     calculateNumberOfLines = answer
  204. End Function
  205.  
  206. Sub DelButtons(ByRef WS As Worksheet)
  207.     Dim btn As Shape
  208.     For Each btn In WS.Shapes
  209.         If btn.AutoShapeType = msoShapeStyleMixed Then btn.Delete
  210.     Next
  211. End Sub
  212.  
  213. Private Sub InitDSU(ByRef pr() As Long, ByRef sz() As Long, ByVal n As Long)
  214.     Dim i As Long
  215.     For i = 0 To n
  216.         pr(i) = i
  217.         sz(i) = 1
  218.     Next i
  219. End Sub
  220. Private Function getInDSU(ByRef pr() As Long, ByVal v As Long) As Long
  221.     If pr(v) = v Then
  222.         getInDSU = v
  223.     Else
  224.         Dim cur As Long
  225.         cur = getInDSU(pr, pr(v))
  226.         pr(v) = cur
  227.         getInDSU = cur
  228.     End If
  229. End Function
  230. Private Function uniteInDsu(ByRef pr() As Long, ByRef sz() As Long, ByVal a As Long, ByVal b As Long) As Long
  231.     a = getInDSU(pr, a)
  232.     b = getInDSU(pr, b)
  233.     If (a <> b) Then
  234.         pr(b) = a
  235.         sz(a) = sz(a) + sz(b)
  236.         uniteInDsu = a
  237.     Else
  238.         uniteInDsu = -1
  239.     End If
  240. End Function
  241.  
  242. 'Just simple max
  243. Function Max(a As Double, b As Double) As Double
  244.     If a > b Then
  245.         Max = a
  246.     Else
  247.         Max = b
  248.     End If
  249. End Function
  250. 'Just simple min
  251. Function Min(a As Double, b As Double) As Double
  252.     If a < b Then
  253.         Min = a
  254.     Else
  255.         Min = b
  256.     End If
  257. End Function
  258. 'Just abs for doubles
  259. Function DoubleAbs(a As Double) As Double
  260.     If a < 0 Then
  261.         DoubleAbs = -a
  262.     Else
  263.         DoubleAbs = a
  264.     End If
  265. End Function
  266.  
  267. Sub SaveExchanges()
  268.     Dim i, j As Long
  269.     ReDim exchangesCopy(numberOfExchanges + 1)
  270.     For i = 1 To numberOfExchanges
  271.         exchangesCopy(i).ExchangeType = exchanges(i).ExchangeType
  272.         exchangesCopy(i).Day = exchanges(i).Day
  273.         exchangesCopy(i).ProjectName = exchanges(i).ProjectName
  274.         exchangesCopy(i).Description = exchanges(i).Description
  275.         For j = 1 To 12
  276.             exchangesCopy(i).Amount(j) = exchanges(i).Amount(j)
  277.         Next j
  278.         exchangesCopy(i).ExchangeRate = exchanges(i).ExchangeRate
  279.         exchangesCopy(i).Manager = exchanges(i).Manager
  280.         exchangesCopy(i).BuyOrSell = exchanges(i).BuyOrSell
  281.         exchangesCopy(i).Pair = exchanges(i).Pair
  282.         exchangesCopy(i).Profit = exchanges(i).Profit
  283.         exchangesCopy(i).CurrencyNumber = exchanges(i).CurrencyNumber
  284.     Next i
  285. End Sub
  286.  
  287. Sub LoadExchanges()
  288.     Dim i, j As Long
  289.     For i = 1 To numberOfExchanges
  290.         exchanges(i).ExchangeType = exchangesCopy(i).ExchangeType
  291.         exchanges(i).Day = exchangesCopy(i).Day
  292.         exchanges(i).ProjectName = exchangesCopy(i).ProjectName
  293.         exchanges(i).Description = exchangesCopy(i).Description
  294.         For j = 1 To 12
  295.             exchanges(i).Amount(j) = exchangesCopy(i).Amount(j)
  296.         Next j
  297.         exchanges(i).ExchangeRate = exchangesCopy(i).ExchangeRate
  298. '        exchanges(i).Manager = exchangesCopy(i).Manager
  299. '        exchanges(i).BuyOrSell = exchangesCopy(i).BuyOrSell
  300. '        exchanges(i).Pair = exchangesCopy(i).Pair
  301. '        exchanges(i).Profit = exchangesCopy(i).Profit
  302. '        exchanges(i).CurrencyNumber = exchangesCopy(i).CurrencyNumber
  303.    Next i
  304. End Sub
  305.  
  306. 'Delete leading zeroes from a string
  307. Private Function DeleteZeroes(ByVal s As String) As String
  308.     Dim res As String
  309.     Dim f As Boolean
  310.     f = False
  311.     For i = 1 To Len(s)
  312.         If Mid(s, i, 1) <> "0" Then f = True
  313.         If f Then res = res & Mid(s, i, 1)
  314.     Next i
  315.     DeleteZeroes = res
  316. End Function
  317.  
  318. 'Check that exchange is made in the needed month
  319. Private Function GoodDay(ByVal s As String) As Boolean
  320.     Dim need As String
  321.     need = DeleteZeroes(MonthToCalculate)
  322.     If need = "" Then
  323.         GoodDay = True
  324.     Else
  325.         Dim american As Boolean
  326.         american = True
  327.         Dim i As Long
  328.         For i = 1 To Len(s)
  329.             If Mid(s, i, 1) = "." Then american = False
  330.         Next i
  331.         Dim res As String
  332.         res = ""
  333.         If american Then
  334.             Dim cntslash As Long
  335.             cntslash = 0
  336.             For i = 1 To Len(s)
  337.                 If Mid(s, i, 1) = "/" Then cntslash = cntslash + 1
  338.                 If cntslash Mod 2 = 0 Then
  339.                     If Mid(s, i, 1) = "/" Then
  340.                         res = res & "."
  341.                     Else
  342.                         res = res & Mid(s, i, 1)
  343.                     End If
  344.                 End If
  345.             Next i
  346.         Else
  347.             cntslash = 0
  348.             For i = 1 To Len(s)
  349.                 If cntslash > 0 Then
  350.                     res = res & Mid(s, i, 1)
  351.                 End If
  352.                 If Mid(s, i, 1) = "." Then cntslash = cntslash + 1
  353.             Next i
  354.         End If
  355.         res = DeleteZeroes(res)
  356.         If res = need Then
  357.             GoodDay = True
  358.         Else
  359.             GoodDay = False
  360.         End If
  361.     End If
  362. End Function
  363.  
  364. Private Sub LeaveOnlyMarked(ByRef WS As Worksheet)
  365.     'useless function
  366. End Sub
  367.  
  368. 'return -1 if profit < 0.1%, 1 if > 2%, 0 if [0.1 ... 2]%, -228 otherwise
  369. Private Function getTypeByProfit(ByRef WS As Worksheet, ByVal i, ByRef ExchangeRate() As Double) As Long
  370.     getTypeByProfit = 0
  371.     Dim posBuy, j As Long
  372.     Dim sum As Double
  373.    
  374.     posBuy = -1
  375.     If exchanges(i).CurrencyNumber <> 0 Then posBuy = exchanges(i).CurrencyNumber
  376.    
  377.     If (posBuy = -1) Then
  378.         getTypeByProfit = -228
  379.     Else
  380.         sum = 0
  381.         For j = 1 To 12
  382.             If exchanges(i).Amount(j) <> 0 Then
  383.                 If (getExchangeRate(WS, i, posBuy, j, ExchangeRate) = -1) Then
  384.                     getTypeByProfit = -228
  385.                     Exit For
  386.                 Else
  387.                     sum = sum + DoubleAbs(exchanges(i).Amount(j)) * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
  388.                 End If
  389.             End If
  390.         Next j
  391.         sum = sum / 2
  392.         If sum = 0 Then getTypeByProfit = -228
  393.         If getTypeByProfit = 0 Then
  394.             exchanges(i).ProfitPercentage = exchanges(i).Profit / sum * 100#
  395.             If exchanges(i).ProfitPercentage < 0.1 Then getTypeByProfit = -1
  396.             If exchanges(i).ProfitPercentage > 2# Then getTypeByProfit = 1
  397.         End If
  398.     End If
  399. End Function
  400.  
  401.  
  402. 'Calculate overal profit from exchanges and print them at the end of the table
  403. Private Sub CalculateSummary(ByRef WS As Worksheet, ByRef ExchangeRate() As Double)
  404.     Dim i As Long, j As Long, cnt As Long, k As Long
  405.     Dim sumL(13), sumU(13), sumTotal(13), profitTotal(13), sumOverAllExchanges(13) As Double
  406.    
  407.     For i = 1 To 12
  408.         sumL(i) = 0
  409.         sumU(i) = 0
  410.         profitTotal(i) = 0
  411.         sumOverAllExchanges(i) = 0
  412.         If i > 4 Then
  413.             sumTotal(i) = 0
  414.             'If IsEmpty(WS.Cells(2, i).Value) = False Then sumTotal(i) = WS.Cells(2, i).Value
  415.        End If
  416.     Next i
  417.    
  418.     Dim names(101) As String
  419.     Dim sumExpenses(101, 18) As Double
  420.     Dim cntNames As Long
  421.     cntNames = 2
  422.     names(0) = "Total" + " expenses"
  423.     names(1) = "Red lines" + " expenses"
  424.     For i = 3 To Rows.Count
  425.         If IsEmpty(Cells(i, 1).Value) Then Exit For
  426.         Dim s As String
  427.         s = Cells(i, 2).Value
  428.         If GoodDay(s) Then
  429.             For j = 5 To 17
  430.                 If j = 6 Then j = j + 1
  431.                 If IsNumeric(Cells(i, j).Value) Then
  432.                     sumOverAllExchanges(j) = sumOverAllExchanges(j) + Cells(i, j).Value
  433.                 End If
  434.             Next j
  435.             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
  436.                 'If (Cells(i, 4).Value Like "*åó÷òåí*") Or (Cells(i, 4).Value Like "*îìèññèÿ*") Then MsgBox i
  437.                For j = 5 To 17
  438.                     If j = 6 Then j = j + 1
  439.                         If IsNumeric(Cells(i, j).Value) Then
  440.                             sumTotal(j) = sumTotal(j) + Cells(i, j).Value
  441.                         End If
  442.                 Next j
  443.             End If
  444.             If Cells(i, 1).Value = "ðàñõîä" Then
  445.                 Dim curPos As Long
  446.                 curPos = 0
  447.                 Do While curPos < cntNames And names(curPos) <> (Cells(i, 3).Value + " expenses")
  448.                     curPos = curPos + 1
  449.                 Loop
  450.                 If Cells(i, 1).Interior.Color = vbRed Then
  451.                     curPos = 1
  452.                 Else
  453.                     If (curPos = cntNames) Then
  454.                         names(curPos) = Cells(i, 3).Value + " expenses"
  455.                         cntNames = cntNames + 1
  456.                     End If
  457.                 End If
  458.                 For j = 5 To 17
  459.                     If j = 6 Then j = j + 1
  460.                     If IsNumeric(Cells(i, j).Value) Then
  461.                         If curPos <> 1 Then sumExpenses(0, j) = sumExpenses(0, j) + Cells(i, j).Value
  462.                         sumExpenses(curPos, j) = sumExpenses(curPos, j) + Cells(i, j).Value
  463.                     End If
  464.                 Next j
  465.             End If
  466.         End If
  467.     Next i
  468.     Dim cntNotEmpty As Long
  469.     cntNotEmpty = 0
  470.     For i = 3 To WS.Rows.Count
  471.         If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
  472.         If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
  473.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  474.         End If
  475.         WS.Cells(i, 22).Value = ""
  476.         If IsEmpty(WS.Cells(i, 19).Value) = False Then
  477.             WS.Cells(i, 19).Value = WS.Cells(i, 19).Value / 2#
  478.         End If
  479.         Dim typeByProfit As Long
  480.         typeByProfit = getTypeByProfit(WS, i, ExchangeRate)
  481.         If (typeByProfit <> -228) Then
  482.             If typeByProfit = -1 Then
  483.                 For j = 1 To 20
  484.                     WS.Cells(i, j).Interior.Color = vbYellow
  485.                 Next j
  486.             End If
  487.             If typeByProfit = 1 Then
  488.                 For j = 1 To 20
  489.                     WS.Cells(i, j).Interior.Color = vbGreen
  490.                 Next j
  491.             End If
  492.         Else
  493.             For j = 1 To 20
  494.                 WS.Cells(i, j).Interior.Color = vbRed
  495.             Next j
  496.         End If
  497.  
  498.         If IsEmpty(WS.Cells(i, 20).Value) = False Then
  499.             j = 5
  500.             Do While j <= 17 And WS.Cells(1, j).Value <> WS.Cells(i, 20).Value
  501.                 j = j + 1
  502.             Loop
  503.  
  504.             If WS.Cells(i, 18).Value = "ë" Then sumL(j) = sumL(j) + WS.Cells(i, 19).Value
  505.             If WS.Cells(i, 18).Value = "þ" Then sumU(j) = sumU(j) + WS.Cells(i, 19).Value
  506.             profitTotal(j) = profitTotal(j) + WS.Cells(i, 19).Value
  507.  
  508.             WS.Cells(i, 21).Value = ""
  509.             cntNotEmpty = cntNotEmpty + 1
  510.         End If
  511.     Next i
  512.     For j = 5 To 17
  513.         WS.Cells(i + 1, j).Value = WS.Cells(1, j).Value
  514.         WS.Cells(i + 2, j).Value = sumTotal(j)
  515.         WS.Cells(i + 5, j).Value = profitTotal(j)
  516.         WS.Cells(i + 8, j).Value = sumL(j)
  517.         WS.Cells(i + 9, j).Value = sumU(j)
  518.     Next j
  519.  
  520.     WS.Cells(i + 2, 4).Value = "Total"
  521.     Call CalculateTotalIn(WS, 5, i + 3, i + 2, ExchangeRate)
  522.     Call CalculateTotalIn(WS, 7, i + 4, i + 2, ExchangeRate)
  523.     WS.Cells(i + 2, 4).Value = "Total (calculated as a simple sum)"
  524.     For k = i + 2 To i + 4
  525.         For j = 4 To 17
  526.             WS.Cells(k, j).Interior.Color = vbGreen
  527.         Next j
  528.     Next k
  529.  
  530.     WS.Cells(i + 5, 4).Value = "Total profit"
  531.     Call CalculateTotalIn(WS, 5, i + 6, i + 5, ExchangeRate)
  532.     Call CalculateTotalIn(WS, 7, i + 7, i + 5, ExchangeRate)
  533.     WS.Cells(i + 5, 4).Value = "Total profit (calculated as a simple sum)"
  534.     For k = i + 5 To i + 7
  535.         For j = 4 To 17
  536.             WS.Cells(k, j).Interior.Color = vbCyan
  537.         Next j
  538.     Next k
  539.  
  540.     WS.Cells(i + 8, 4).Value = "Ïðèáûëü Ë"
  541.     WS.Cells(i + 9, 4).Value = "Ïðèáûëü Þ"
  542.     For j = 4 To 17
  543.         WS.Cells(i + 8, j).Interior.Color = vbYellow
  544.         WS.Cells(i + 9, j).Interior.Color = RGB(255, 120, 200)
  545.     Next j
  546.    
  547.     names(cntNames) = "Sum over all exchanges"
  548.     For j = 5 To 17
  549.         sumExpenses(cntNames, j) = sumOverAllExchanges(j)
  550.     Next j
  551.     cntNames = cntNames + 1
  552.     For k = 0 To cntNames - 1
  553.         For j = 5 To 17
  554.             WS.Cells(i + 12 + k * 3, j).Value = sumExpenses(k, j)
  555.         Next j
  556.         WS.Cells(i + 12 + k * 3, 4).Value = names(k)
  557.         Call CalculateTotalIn(WS, 5, i + 13 + k * 3, i + 12 + k * 3, ExchangeRate)
  558.         Call CalculateTotalIn(WS, 7, i + 14 + k * 3, i + 12 + k * 3, ExchangeRate)
  559.         If k = 0 Then
  560.             WS.Cells(i + 12 + k * 3, 4).Value = CStr(WS.Cells(i + 12 + k * 3, 4).Value + " (calculated as a simple sum)")
  561.         End If
  562.         For j = 4 To 17
  563.             WS.Cells(i + 12 + k * 3, j).Interior.Color = RGB(255 - k - 1, 255, 255)
  564.             WS.Cells(i + 13 + k * 3, j).Interior.Color = RGB(255 - k - 1, 255, 255)
  565.             WS.Cells(i + 14 + k * 3, j).Interior.Color = RGB(255 - k - 1, 255, 255)
  566.         Next j
  567.         If k = cntNames - 1 Then
  568.             For j = 4 To 17
  569.                 WS.Cells(i + 12 + k * 3, j).Interior.Color = RGB(30, 200, 0)
  570.                 WS.Cells(i + 13 + k * 3, j).Interior.Color = RGB(30, 200, 0)
  571.                 WS.Cells(i + 14 + k * 3, j).Interior.Color = RGB(30, 200, 0)
  572.             Next j
  573.         End If
  574.     Next k
  575.    
  576.     'MsgBox "CalculateSummary " & cntNotEmpty
  577. End Sub
  578.  
  579.  
  580. 'Calculate overal profit from exchanges and print them at the end of the table
  581. Private Function printBonus(ByRef WS As Worksheet) As Long
  582.     Dim i As Long, j As Long, cnt As Long, k As Long
  583.     Dim sumL(17) As Double, sumU(17) As Double
  584.     For i = 1 To 17
  585.         sumL(i) = 0
  586.         sumU(i) = 0
  587.     Next i
  588.     For i = 3 To WS.Rows.Count
  589.         If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
  590.         If IsEmpty(WS.Cells(i, 19).Value) = False Then
  591.             j = 5
  592.             Do While j <= 17 And WS.Cells(1, j).Value <> WS.Cells(i, 19).Value
  593.                 j = j + 1
  594.             Loop
  595.            
  596.             If WS.Cells(i, 24).Value = "ë" Then sumL(j) = sumL(j) + WS.Cells(i, 23).Value
  597.             If WS.Cells(i, 24).Value = "þ" Then sumU(j) = sumU(j) + WS.Cells(i, 23).Value
  598.         End If
  599.     Next i
  600.     For j = 5 To 17
  601.         WS.Cells(i + 10, j).Value = CDbl(sumL(j))
  602.         WS.Cells(i + 10, j).NumberFormat = "0.00"
  603.         WS.Cells(i + 11, j).Value = CDbl(sumU(j))
  604.         WS.Cells(i + 11, j).NumberFormat = "0.00"
  605.     Next j
  606.     WS.Cells(i + 10, 4).Value = "Áîíóñ Ë"
  607.     WS.Cells(i + 11, 4).Value = "Áîíóñ Þ"
  608.     For j = 4 To 17
  609.         WS.Cells(i + 10, j).Interior.Color = vbYellow
  610.         WS.Cells(i + 11, j).Interior.Color = RGB(255, 120, 200)
  611.     Next j
  612.     printBonus = i + 11
  613.     Do While IsEmpty(WS.Cells(printBonus + 1, 4).Value) = False
  614.         printBonus = printBonus + 1
  615.     Loop
  616. End Function
  617.  
  618. Private Sub calculateSumOfProfit(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef sumOfProfit() As Double)
  619.     Dim i, j As Long
  620.     Dim add As Double
  621.    
  622.     Call RecalculateExchangeRates(WS, i, ExchangeRate, 3)
  623.     For i = 1 To numberOfExchanges
  624.         If i > 1 And exchanges(i).Day <> exchanges(i - 1).Day Then
  625.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  626.         End If
  627.         If exchanges(i).CurrencyNumber <> 0 And exchanges(i).DealNumber <> 0 Then
  628.             add = exchanges(i).Profit * getExchangeRate(WS, i, 2, exchanges(i).CurrencyNumber, ExchangeRate)
  629.             sumOfProfit(exchanges(i).DealNumber) = sumOfProfit(exchanges(i).DealNumber) + add
  630.         End If
  631.     Next i
  632. End Sub
  633.  
  634. Private Sub calculateDealSum(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef dealBuySum() As Double, ByRef dealSellSum() As Double, ByRef dealType() As String)
  635.     Dim i, j As Long
  636.     Dim sumPositive, sumNegative As Double
  637.     Dim positiveFlag, negativeFlag As Boolean
  638.     Dim posBuy, cnt As Long
  639.     Dim sum As Double
  640.            
  641.     Call RecalculateExchangeRates(WS, i, ExchangeRate, 3)
  642.     For i = 1 To numberOfExchanges
  643.         If i > 1 And exchanges(i).Day <> exchanges(i - 1).Day Then
  644.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  645.         End If
  646.        
  647.         If exchanges(i).DealNumber <> 0 Then
  648.             positiveFlag = True
  649.             negativeFlag = True
  650.             sumPositive = 0
  651.             sumNegative = 0
  652.            
  653.             posBuy = exchanges(i).CurrencyNumber
  654.             If posBuy <> 0 Then
  655.                 For j = 1 To 12
  656.                     If exchanges(i).Amount(j) <> 0 Then
  657.                         If exchanges(i).Amount(j) < 0 Then
  658.                             If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
  659.                                 sumNegative = sumNegative - exchanges(i).Amount(j) * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
  660.                             Else
  661.                                 negativeFlag = False
  662.                             End If
  663.                         End If
  664.                         If exchanges(i).Amount(j) > 0 Then
  665.                             If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
  666.                                 sumPositive = sumPositive + exchanges(i).Amount(j) * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
  667.                             Else
  668.                                 positiveFlag = False
  669.                             End If
  670.                         End If
  671.                     End If
  672.                 Next j
  673.                
  674.                 cnt = 0
  675.                 sum = 0
  676.                 If positiveFlag Then
  677.                     cnt = cnt + 1
  678.                     sum = sum + sumPositive
  679.                 End If
  680.                 If negativeFlag Then
  681.                     cnt = cnt + 1
  682.                     sum = sum + sumNegative
  683.                 End If
  684.                 If (cnt <> 0) Then
  685.                     If (dealType(i) = "Buy") Then
  686.                         If positiveFlag Then
  687.                             sum = sumPositive
  688.                             cnt = 1
  689.                         End If
  690.                         dealBuySum(exchanges(i).DealNumber) = dealBuySum(exchanges(i).DealNumber) + (sum / cnt)
  691.                     Else
  692.                         If positiveFlag Then
  693.                             sum = sumPositive
  694.                             cnt = 1
  695.                         End If
  696.                         dealSellSum(exchanges(i).DealNumber) = dealSellSum(exchanges(i).DealNumber) + (sum / cnt)
  697.                     End If
  698.                 Else
  699.                     exchanges(i).Errors = exchanges(i).Errors + "(calculateDealSum error) "
  700.                 End If
  701.             End If
  702.         End If
  703.     Next i
  704. End Sub
  705.  
  706. Private Sub calculateBonusWithDealSum(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef dealBuySum() As Double, ByRef dealSellSum() As Double, ByRef dealType() As String)
  707.     Dim i As Long
  708.     For i = 3 To WS.Rows.Count
  709.         If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
  710.         If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
  711.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  712.         End If
  713.         If IsEmpty(WS.Cells(i, 22).Value) = False Then
  714.             Dim sumPositive, sumNegative As Double
  715.             Dim positiveFlag, negativeFlag As Boolean
  716.             positiveFlag = True
  717.             negativeFlag = True
  718.             sumPositive = 0
  719.             sumNegative = 0
  720.            
  721.             Dim posBuy As Long
  722.             posBuy = 5
  723.             Do While posBuy < 18 And WS.Cells(1, posBuy).Value <> WS.Cells(i, 20).Value
  724.                 posBuy = posBuy + 1
  725.             Loop
  726.             If (posBuy < 18) Then
  727.                 Dim j As Long
  728.                 For j = 5 To 17
  729.                     If j = 6 Then j = j + 1
  730.                     If IsEmpty(WS.Cells(i, j).Value) = False Then
  731.                         If (WS.Cells(i, j).Value < 0) Then
  732.                             If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
  733.                                 sumNegative = sumNegative - WS.Cells(i, j).Value * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
  734.                             Else
  735.                                 negativeFlag = False
  736.                             End If
  737.                         End If
  738.                         If (WS.Cells(i, j).Value > 0) Then
  739.                             If getExchangeRate(WS, i, posBuy, j, ExchangeRate) <> -1 Then
  740.                                 sumPositive = sumPositive + WS.Cells(i, j).Value * getExchangeRate(WS, i, posBuy, j, ExchangeRate)
  741.                             Else
  742.                                 positiveFlag = False
  743.                             End If
  744.                         End If
  745.                     End If
  746.                 Next j
  747.                
  748.                 Dim cnt As Long
  749.                 cnt = 0
  750.                 Dim sum As Double
  751.                 sum = 0
  752.                 If positiveFlag Then
  753.                     cnt = cnt + 1
  754.                     sum = sum + sumPositive
  755.                 End If
  756.                 If negativeFlag Then
  757.                     cnt = cnt + 1
  758.                     sum = sum + sumNegative
  759.                 End If
  760.                 If (cnt <> 0) Then
  761.                     If dealType(i) = "Buy" Then
  762.                         If positiveFlag Then
  763.                             sum = sumPositive
  764.                             cnt = 1
  765.                         End If
  766.                         WS.Cells(i, 24).Value = (sum / cnt) / dealBuySum(WS.Cells(i, 22).Value) * WS.Cells(i, 23).Value / 10#
  767.                         'If (WS.Cells(i, 24).Value > DoubleAbs(WS.Cells(i, 19).Value)) Then WS.Cells(i, 24).Value = DoubleAbs(WS.Cells(i, 19).Value)
  768.                        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
  769.                     Else
  770.                         If positiveFlag Then
  771.                             sum = sumPositive
  772.                             cnt = 1
  773.                         End If
  774.                         WS.Cells(i, 24).Value = (sum / cnt) / dealSellSum(WS.Cells(i, 22).Value) * WS.Cells(i, 23).Value / 10#
  775.                         'If (WS.Cells(i, 24).Value > DoubleAbs(WS.Cells(i, 19).Value)) Then WS.Cells(i, 24).Value = DoubleAbs(WS.Cells(i, 19).Value)
  776.                        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
  777.                     End If
  778.                 Else
  779.                     WS.Cells(i, 24).Value = "NO BONUS"
  780.                 End If
  781.             End If
  782.         End If
  783.     Next i
  784. End Sub
  785. 'Converts Total in RUB
  786. Private Sub CalculateTotalIn(ByRef WS As Worksheet, ByVal toWhat As Long, ByVal resultLine As Long, ByVal totalLine As Long, ByRef ExchangeRate() As Double)
  787.     Dim j As Long
  788.     Dim sum As Double
  789.     sum = 0
  790.     For j = 5 To 17
  791.         If j = 6 Then j = j + 1
  792.         If IsEmpty(WS.Cells(totalLine, j).Value) = False And WS.Cells(totalLine, j).Value <> 0 Then
  793.             If ExchangeRate(toWhat, j) <> -1 Then
  794.                 sum = sum + WS.Cells(totalLine, j).Value * ExchangeRate(toWhat, j)
  795.             Else
  796.                 If ExchangeRate(7, j) <> -1 And ExchangeRate(toWhat, 7) <> -1 Then
  797.                     sum = sum + WS.Cells(totalLine, j).Value * ExchangeRate(toWhat, 7) * ExchangeRate(7, j)
  798.                 End If
  799.             End If
  800.         Else
  801.         End If
  802.     Next j
  803.     Dim cur As String
  804.     cur = WS.Cells(1, toWhat).Value
  805.     WS.Cells(resultLine, 4).Value = WS.Cells(totalLine, 4).Value & " in " & WS.Cells(1, toWhat).Value
  806.     WS.Cells(resultLine, toWhat).Value = sum
  807. End Sub
  808.  
  809.  
  810. 'Calculate array exchangeRate with contains exchange rates for some particular day
  811. Private Sub RecalculateExchangeRates(ByRef WS As Worksheet, ByVal x As Long, ByRef ExchangeRate() As Double, Optional ByVal numberOfDays As Long = 1)
  812. ' ExchangeRate(i, j) = how many I you can buy for one J
  813.    Dim sumI(13, 13), sumJ(13, 13), rubUsd As Double
  814.     Dim i, j, k, cntRubUsd As Long
  815.    
  816.     For i = 0 To 12
  817.         For j = 0 To 12
  818.             sumI(i, j) = 0
  819.             sumJ(i, j) = 0
  820.         Next j
  821.     Next i
  822.    
  823.     rubUsd = 0
  824.     cntRubUsd = 0
  825.     Do While numberOfDays > 0 And x <= numberOfExchanges
  826.         If IsEmpty(WS.Cells(x, 19).Value) Then
  827.             If IsEmpty(WS.Cells(x, 6).Value) = False Then
  828.                 rubUsd = rubUsd + WS.Cells(x, 6).Value
  829.                 cntRubUsd = cntRubUsd + 1
  830.             End If
  831.             Dim posSell As Long, posBuy As Long, cnt As Long
  832.             posSell = 0
  833.             posBuy = 0
  834.             cnt = 0
  835.             For j = 5 To 17
  836.                 If j = 6 Then j = j + 1
  837.                 If WS.Cells(x, j).Value <> 0 Then
  838.                     cnt = cnt + 1
  839.                     If WS.Cells(x, j).Value < 0 Then
  840.                         posSell = j
  841.                     Else
  842.                         posBuy = j
  843.                     End If
  844.                 End If
  845.             Next j
  846.             If (cnt = 2 And posSell <> 0 And posBuy <> 0) Then
  847.                 sumI(posSell, posBuy) = sumI(posSell, posBuy) + DoubleAbs(WS.Cells(x, posSell).Value)
  848.                 sumJ(posSell, posBuy) = sumJ(posSell, posBuy) + DoubleAbs(WS.Cells(x, posBuy).Value)
  849.                 sumI(posBuy, posSell) = sumI(posBuy, posSell) + DoubleAbs(WS.Cells(x, posBuy).Value)
  850.                 sumJ(posBuy, posSell) = sumJ(posBuy, posSell) + DoubleAbs(WS.Cells(x, posSell).Value)
  851.             End If
  852.         End If
  853.         If WS.Cells(x + 1, 2).Value <> WS.Cells(x, 2).Value Then numberOfDays = numberOfDays - 1
  854.         x = x + 1
  855.     Loop
  856.     For i = 5 To 17
  857.         If i = 6 Then i = i + 1
  858.         For j = 5 To 17
  859.             If j = 6 Then j = j + 1
  860.             If i = j Then ExchangeRate(i, j) = 1
  861.             If sumJ(i, j) <> 0 Then
  862.                 ExchangeRate(i, j) = sumI(i, j) / sumJ(i, j)
  863.             End If
  864.         Next j
  865.     Next i
  866.     If sumJ(5, 7) <> 0 Then
  867.         rubUsd = rubUsd + sumI(5, 7) / sumJ(5, 7)
  868.         cntRubUsd = cntRubUsd + 1
  869.     End If
  870.     If cntRubUsd <> 0 Then
  871.         ExchangeRate(5, 7) = rubUsd / cntRubUsd
  872.         ExchangeRate(7, 5) = cntRubUsd / rubUsd
  873.     End If
  874. End Sub
  875.  
  876. 'The main function to calculate profit
  877. 'Makes matches between exchanges
  878. Private Sub SuperDuper(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef ansector() As Long, ByRef sz() As Long, ByRef exchangeOveralCirculation() As Double)
  879.     Dim i As Long, j As Long, k As Long
  880.     Dim allBuy(5 To 17, 5 To 17, 2000) As Long
  881.     Dim allBuySize(5 To 17, 5 To 17) As Long
  882.     Dim allSell(5 To 17, 5 To 17, 2000) As Long
  883.     Dim allSellSize(5 To 17, 5 To 17) As Long
  884.     For i = 5 To 17
  885.         For j = 5 To 17
  886.             allBuySize(i, j) = 0
  887.             allSellSize(i, j) = 0
  888.         Next j
  889.     Next i
  890.     Dim magicalPercent As Double
  891.     magicalPercent = 0.017
  892.     For i = 3 To Rows.Count
  893.         If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
  894.         Dim ii As Long
  895.         ii = i
  896.         If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
  897.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  898.         End If
  899.         i = ii
  900.         If IsEmpty(WS.Cells(i, 22).Value) = False And IsEmpty(WS.Cells(i, 20).Value) = True Then
  901.             Dim posSell As Long, posBuy As Long, cnt As Long
  902.             posSell = 0
  903.             posBuy = 0
  904.             cnt = 0
  905.             For j = 5 To 17
  906.                 If j = 6 Then j = j + 1
  907.                 If WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False Then
  908.                     cnt = cnt + 1
  909.                     If WS.Cells(i, j).Value < 0 Then
  910.                         posSell = j
  911.                     Else
  912.                         posBuy = j
  913.                     End If
  914.                 End If
  915.             Next j
  916.             If (posSell = 0 Or posBuy = 0) Then
  917.                 Dim sum As Double
  918.                 sum = 0
  919.                 For j = 5 To 17
  920.                     If j = 6 Then j = j + 1
  921.                     If WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False And getExchangeRate(WS, i, 7, j, ExchangeRate) <> -1 Then
  922.                         sum = sum + WS.Cells(i, j).Value * getExchangeRate(WS, i, 7, j, ExchangeRate)
  923.                     End If
  924.                 Next j
  925.                 WS.Cells(i, 19).Value = sum
  926.                 WS.Cells(i, 20).Value = WS.Cells(1, 7).Value
  927.                 cnt = 0
  928.             End If
  929.             If cnt = 2 Then
  930.                 Dim cntDays As Long, last As Long
  931.                 cntDays = 5
  932.                 last = -1
  933.                 If WS.Cells(i, 22).Value = "Buy" Then
  934.                     Dim curExchangeRate As Double, pastExchangeRate As Double
  935.                     If WS.Cells(i, posBuy).Value <> 0 Then
  936.                         curExchangeRate = -WS.Cells(i, posSell).Value / WS.Cells(i, posBuy).Value
  937.                         last = i
  938.                         For j = allSellSize(posBuy, posSell) - 1 To 0 Step -1
  939.                             If j < allBuySize(posBuy, posSell) - 50 Then Exit For
  940.                         'For j = 0 To allBuySize(posBuy, posSell) - 1
  941.                            k = allSell(posBuy, posSell, j)
  942.                             If WS.Cells(k, 2).Value <> WS.Cells(last, 2).Value Then cntDays = cntDays - 1
  943.                             If cntDays = 0 Then Exit For
  944.                             last = k
  945.                             If WS.Cells(k, posBuy).Value <> 0 Then
  946.                                 pastExchangeRate = -WS.Cells(k, posSell).Value / WS.Cells(k, posBuy).Value
  947.                                 If pastExchangeRate > curExchangeRate Then
  948.                                     Dim componentNumber As Long
  949.                                     'WS.Cells(cur, 21).Value = pr
  950.                                    'WS.Cells(pr, 21).Value = cur
  951.                                    Dim add As Double, Amount As Double
  952.                                     Amount = Min(WS.Cells(i, posBuy).Value, -WS.Cells(k, posBuy).Value)
  953.                                     add = (pastExchangeRate - curExchangeRate) * Amount
  954.                                     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
  955.                                         componentNumber = uniteInDsu(ansector, sz, k, i)
  956.                                     End If
  957.  
  958.                                     WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + Amount
  959.                                     WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - Amount * pastExchangeRate
  960.                                     WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - Amount
  961.                                     WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + Amount * curExchangeRate
  962.  
  963.                                     WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
  964.                                     WS.Cells(i, 20).Value = WS.Cells(1, posSell).Value
  965.                                     WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
  966.                                     WS.Cells(k, 20).Value = WS.Cells(i, 20).Value
  967.                                    
  968.                                     'If IsEmpty(WS.Cells(i, 25).Value) Then WS.Cells(i, 25).Value = 0
  969.                                    'If IsEmpty(WS.Cells(k, 25).Value) Then WS.Cells(k, 25).Value = 0
  970.                                    'WS.Cells(i, 25).Value = WS.Cells(i, 25).Value + add / 2
  971.                                    'WS.Cells(k, 25).Value = WS.Cells(k, 25).Value + add / 2
  972.                                End If
  973.                             End If
  974.                         Next j
  975. '                        For j = allSellSize(posBuy, posSell) - 1 To 0 Step -1
  976. '                        'For j = 0 To allBuySize(posBuy, posSell) - 1
  977. '                            k = allSell(posBuy, posSell, j)
  978. '                            If WS.Cells(k, posBuy).Value <> 0 Then
  979. '                                pastExchangeRate = -WS.Cells(k, posSell).Value / WS.Cells(k, posBuy).Value
  980. '                                If True Then
  981. '                                    'WS.Cells(cur, 21).Value = pr
  982. '                                    'WS.Cells(pr, 21).Value = cur
  983. '                                    amount = Min(WS.Cells(i, posBuy).Value, -WS.Cells(k, posBuy).Value)
  984. '                                    add = (pastExchangeRate - curExchangeRate) * amount
  985. '
  986. '                                    WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + amount
  987. '                                    WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - amount * pastExchangeRate
  988. '                                    WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - amount
  989. '                                    WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + amount * curExchangeRate
  990. '
  991. '                                    WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
  992. '                                    WS.Cells(i, 20).Value = WS.Cells(1, posSell).Value
  993. '                                    WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
  994. '                                    WS.Cells(k, 20).Value = WS.Cells(i, 20).Value
  995. '                                End If
  996. '                            End If
  997. '                        Next j
  998.                    End If
  999.                     '-----------------------------------------------------------------
  1000.                    allBuy(posSell, posBuy, allBuySize(posSell, posBuy)) = i
  1001.                     allBuySize(posSell, posBuy) = allBuySize(posSell, posBuy) + 1
  1002.                 Else 'WS.Cells(i, 22).Value = "Sell"
  1003.                    If WS.Cells(i, posSell).Value <> 0 Then
  1004.                         curExchangeRate = -WS.Cells(i, posBuy).Value / WS.Cells(i, posSell).Value
  1005.                         last = i
  1006.                         For j = allBuySize(posBuy, posSell) - 1 To 0 Step -1
  1007.                             If j < allBuySize(posBuy, posSell) - 50 Then Exit For
  1008.                         'For j = 0 To allBuySize(posBuy, posSell) - 1
  1009.                            k = allBuy(posBuy, posSell, j)
  1010.                             If WS.Cells(k, 2).Value <> WS.Cells(last, 2).Value Then cntDays = cntDays - 1
  1011.                             If cntDays = 0 Then Exit For
  1012.                             last = k
  1013.                             If WS.Cells(k, posSell).Value <> 0 Then
  1014.                                 pastExchangeRate = -WS.Cells(k, posBuy).Value / WS.Cells(k, posSell).Value
  1015.                                 If pastExchangeRate < curExchangeRate Then
  1016.                                     'WS.Cells(cur, 21).Value = pr
  1017.                                    'WS.Cells(pr, 21).Value = cur
  1018.                                    Amount = Min(-WS.Cells(i, posSell).Value, WS.Cells(k, posSell).Value)
  1019.                                     add = (curExchangeRate - pastExchangeRate) * Amount
  1020.                                     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
  1021.                                         componentNumber = uniteInDsu(ansector, sz, k, i)
  1022.                                     End If
  1023.        
  1024.                                     WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + Amount * pastExchangeRate
  1025.                                     WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - Amount
  1026.                                     WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - Amount * curExchangeRate
  1027.                                     WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + Amount
  1028.        
  1029.                                     WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
  1030.                                     WS.Cells(i, 20).Value = WS.Cells(1, posBuy).Value
  1031.                                     WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
  1032.                                     WS.Cells(k, 20).Value = WS.Cells(i, 20).Value
  1033.                                    
  1034.                                     'If IsEmpty(WS.Cells(i, 25).Value) Then WS.Cells(i, 25).Value = 0
  1035.                                    'If IsEmpty(WS.Cells(k, 25).Value) Then WS.Cells(k, 25).Value = 0
  1036.                                    'WS.Cells(i, 25).Value = WS.Cells(i, 25).Value + add / 2
  1037.                                    'WS.Cells(k, 25).Value = WS.Cells(k, 25).Value + add / 2
  1038.                                End If
  1039.                             End If
  1040.                         Next j
  1041.                         last = i
  1042.                         For j = allBuySize(posBuy, posSell) - 1 To 0 Step -1
  1043.                             If j < allBuySize(posBuy, posSell) - 50 Then Exit For
  1044.                             k = allBuy(posBuy, posSell, j)
  1045.                             If WS.Cells(k, 2).Value <> WS.Cells(last, 2).Value Then cntDays = cntDays - 1
  1046.                             If cntDays = 0 Then Exit For
  1047.                             last = k
  1048.                             If WS.Cells(k, posSell).Value <> 0 Then
  1049.                                 pastExchangeRate = -WS.Cells(k, posBuy).Value / WS.Cells(k, posSell).Value
  1050.                                 If True Then
  1051.                                     'WS.Cells(cur, 21).Value = pr
  1052.                                    'WS.Cells(pr, 21).Value = cur
  1053.                                    'Dim add As Double, amount As Double
  1054.                                    Amount = Min(-WS.Cells(i, posSell).Value, WS.Cells(k, posSell).Value)
  1055.                                     add = (curExchangeRate - pastExchangeRate) * Amount
  1056.                                     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
  1057.                                         componentNumber = uniteInDsu(ansector, sz, k, i)
  1058.                                     End If
  1059.                                    
  1060.                                     WS.Cells(k, posBuy).Value = WS.Cells(k, posBuy).Value + Amount * pastExchangeRate
  1061.                                     WS.Cells(k, posSell).Value = WS.Cells(k, posSell).Value - Amount
  1062.                                     WS.Cells(i, posBuy).Value = WS.Cells(i, posBuy).Value - Amount * curExchangeRate
  1063.                                     WS.Cells(i, posSell).Value = WS.Cells(i, posSell).Value + Amount
  1064.        
  1065.                                     WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + add
  1066.                                     WS.Cells(i, 20).Value = WS.Cells(1, posBuy).Value
  1067.                                     WS.Cells(k, 19).Value = WS.Cells(k, 19).Value + add
  1068.                                     WS.Cells(k, 20).Value = WS.Cells(i, 20).Value
  1069.                                    
  1070.                                     'If IsEmpty(WS.Cells(i, 25).Value) Then WS.Cells(i, 25).Value = 0
  1071.                                    'If IsEmpty(WS.Cells(k, 25).Value) Then WS.Cells(k, 25).Value = 0
  1072.                                    'WS.Cells(i, 25).Value = WS.Cells(i, 25).Value + add / 2
  1073.                                    'WS.Cells(k, 25).Value = WS.Cells(k, 25).Value + add / 2
  1074.                                End If
  1075.                             End If
  1076.                         Next j
  1077.                     End If
  1078.                     '---------------------------
  1079.                    allSell(posSell, posBuy, allSellSize(posSell, posBuy)) = i
  1080.                     allSellSize(posSell, posBuy) = allSellSize(posSell, posBuy) + 1
  1081.                 End If
  1082.             End If
  1083.         End If
  1084.     Next i
  1085.     'MsgBox "SuperDuper"
  1086. End Sub
  1087.  
  1088. 'Some editional matching for exchanges
  1089. 'It work perfectly with exchanges that are almost equal
  1090. Private Sub DeleteEqual(ByRef WS As Worksheet, ByRef ansector() As Long, ByRef sz() As Long, ByRef ExchangeRate() As Double)
  1091.     Dim i As Long, lastDay As Long
  1092.     lastDay = 2
  1093.     Call RecalculateExchangeRates(WS, 3, ExchangeRate)
  1094.     For i = 3 To Rows.Count
  1095.         If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
  1096.         Dim last As Long
  1097.         last = i
  1098.         Do While WS.Cells(last, 2).Value = WS.Cells(last + 1, 2).Value
  1099.             last = last + 1
  1100.         Loop
  1101.         Dim ii As Long
  1102.         ii = i
  1103.         If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
  1104.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  1105.         End If
  1106.         i = ii
  1107.         Dim cur As Long, pr As Long, j As Long
  1108.         For cur = i To last
  1109. '               Check just the same lines
  1110.            For pr = lastDay To cur - 1
  1111.                 If IsEmpty(WS.Cells(pr, 21).Value) Then
  1112.                     Dim cnt As Long, pos As Long
  1113.                     cnt = 0
  1114.                     pos = 5
  1115.                     For j = 5 To 17
  1116.                         If j = 6 Then j = j + 1
  1117.                         If IsEmpty(WS.Cells(cur, j).Value) <> IsEmpty(WS.Cells(pr, j).Value) Then
  1118.                             cnt = 228
  1119.                             Exit For
  1120.                         End If
  1121.                         If IsEmpty(WS.Cells(cur, j).Value) = False Then
  1122.                             If WS.Cells(cur, j).Value + WS.Cells(pr, j).Value <> 0 Then
  1123.                                 cnt = cnt + 1
  1124.                                 pos = j
  1125.                             End If
  1126.                         End If
  1127.                     Next j
  1128.                     If cnt = 0 Then
  1129.                         Dim componentNumber As Long
  1130.                         componentNumber = uniteInDsu(ansector, sz, pr, cur)
  1131.                         WS.Cells(cur, 21).Value = pr
  1132.                         WS.Cells(pr, 21).Value = cur
  1133.                         WS.Cells(cur, 19).Value = 0
  1134.                         WS.Cells(cur, 20).Value = WS.Cells(1, pos).Value
  1135.                         WS.Cells(pr, 19).Value = WS.Cells(cur, 19).Value
  1136.                         WS.Cells(pr, 20).Value = WS.Cells(cur, 20).Value
  1137.                         'If IsEmpty(WS.Cells(cur, 25).Value) Then WS.Cells(cur, 25).Value = 0
  1138.                        'If IsEmpty(WS.Cells(pr, 25).Value) Then WS.Cells(pr, 25).Value = 0
  1139.                        'WS.Cells(cur, 25).Value = WS.Cells(cur, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
  1140.                        'WS.Cells(pr, 25).Value = WS.Cells(pr, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
  1141.                        For j = 5 To 17
  1142.                             If j = 6 Then j = j + 1
  1143.                             If IsEmpty(WS.Cells(cur, j).Value) = False Then
  1144.                                 WS.Cells(cur, j).Value = ""
  1145.                             End If
  1146.                             If IsEmpty(WS.Cells(pr, j).Value) = False Then
  1147.                                 WS.Cells(pr, j).Value = ""
  1148.                             End If
  1149.                         Next j
  1150.                         Exit For
  1151.                     End If
  1152.                     If cnt = 1 Then
  1153.                         componentNumber = uniteInDsu(ansector, sz, pr, cur)
  1154.                         WS.Cells(cur, 21).Value = pr
  1155.                         WS.Cells(pr, 21).Value = cur
  1156.                         WS.Cells(cur, 19).Value = WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value
  1157.                         WS.Cells(cur, 20).Value = WS.Cells(1, pos).Value
  1158.                         WS.Cells(pr, 19).Value = WS.Cells(cur, 19).Value
  1159.                         WS.Cells(pr, 20).Value = WS.Cells(cur, 20).Value
  1160.                         'If IsEmpty(WS.Cells(cur, 25).Value) Then WS.Cells(cur, 25).Value = 0
  1161.                        'If IsEmpty(WS.Cells(pr, 25).Value) Then WS.Cells(pr, 25).Value = 0
  1162.                        'WS.Cells(cur, 25).Value = WS.Cells(cur, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
  1163.                        'WS.Cells(pr, 25).Value = WS.Cells(pr, 25).Value + (WS.Cells(cur, pos).Value + WS.Cells(pr, pos).Value) / 2
  1164.                        For j = 5 To 17
  1165.                             If j = 6 Then j = j + 1
  1166.                             If IsEmpty(WS.Cells(cur, j).Value) = False Then
  1167.                                 WS.Cells(cur, j).Value = ""
  1168.                             End If
  1169.                             If IsEmpty(WS.Cells(pr, j).Value) = False Then
  1170.                                 WS.Cells(pr, j).Value = ""
  1171.                             End If
  1172.                         Next j
  1173.  
  1174.                         Exit For
  1175.                     End If
  1176.                 End If
  1177.             Next pr
  1178.         Next cur
  1179.         lastDay = i
  1180.         i = last
  1181.     Next i
  1182.     'MsgBox "DeleteEqual"
  1183. End Sub
  1184.  
  1185. 'Remained currencies just summarize to the profit of exchange
  1186. Private Sub AddRest(ByRef WS As Worksheet, ByRef ExchangeRate() As Double)
  1187.     For i = 3 To Rows.Count
  1188.         If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
  1189.         Dim ii As Long
  1190.         ii = i
  1191.         If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
  1192.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  1193.         End If
  1194.         i = ii
  1195.        
  1196.         Dim f As Boolean
  1197.         f = True
  1198.         If IsEmpty(WS.Cells(i, 19).Value) = True Then
  1199.             WS.Cells(i, 19).Value = 0
  1200.             WS.Cells(i, 20).Value = WS.Cells(1, 7).Value
  1201.         Else
  1202.             j = 5
  1203.             Do While WS.Cells(1, j).Value <> WS.Cells(i, 20).Value
  1204.                 j = j + 1
  1205.             Loop
  1206.             If (getExchangeRate(WS, i, 7, j, ExchangeRate) = -1) Then
  1207.                 f = False
  1208.             Else
  1209.                 WS.Cells(i, 19).Value = WS.Cells(i, 19).Value * getExchangeRate(WS, i, 7, j, ExchangeRate)
  1210.                 WS.Cells(i, 20).Value = WS.Cells(1, 7).Value
  1211.             End If
  1212.         End If
  1213.         For j = 5 To 17
  1214.             If j = 6 Then j = j + 1
  1215.             If WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False Then
  1216.                 If (ExchangeRate(7, j) = -1) Then f = False
  1217.             End If
  1218.         Next j
  1219.         For j = 5 To 17
  1220.             If j = 6 Then j = j + 1
  1221.             If f And WS.Cells(i, j).Value <> 0 And IsEmpty(WS.Cells(i, j).Value) = False Then
  1222.                 WS.Cells(i, 19).Value = WS.Cells(i, 19).Value + WS.Cells(i, j) * ExchangeRate(7, j)
  1223.             End If
  1224.         Next j
  1225.     Next i
  1226. End Sub
  1227.  
  1228. 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
  1229.     getExchangeRate = ExchangeRate(x, y)
  1230.     If IsEmpty(WS.Cells(i, 6).Value) = False Then
  1231.         If x = 5 And y = 7 Then getExchangeRate = WS.Cells(i, 6).Value
  1232.         If x = 7 And y = 5 Then getExchangeRate = 1# / WS.Cells(i, 6).Value
  1233.     End If
  1234. End Function
  1235.  
  1236. Private Sub CalculateExchangeOveralCirculation(ByRef WS As Worksheet, ByRef exchangeOveralCirculation() As Double, ByRef ExchangeRate() As Double)
  1237.     Dim i As Long
  1238.     For i = 3 To WS.Rows.Count
  1239.         If IsEmpty(WS.Cells(i, 1).Value) Then Exit For
  1240.         If WS.Cells(i, 2).Value <> WS.Cells(i - 1, 2).Value Then
  1241.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  1242.         End If
  1243.         Dim j As Long
  1244.         For j = 5 To 17
  1245.             If j = 6 Then j = 7
  1246.             If IsEmpty(WS.Cells(i, j).Value) = False And getExchangeRate(WS, i, 7, j, ExchangeRate) <> -1 Then
  1247.                 exchangeOveralCirculation(i) = exchangeOveralCirculation(i) + DoubleAbs(WS.Cells(i, j).Value) * getExchangeRate(WS, i, 7, j, ExchangeRate)
  1248.             End If
  1249.         Next j
  1250.     Next i
  1251. End Sub
  1252.  
  1253.  
  1254. 'Cells(i, 21) = "Sell" or "Buy", if we by crypto, then it is "Buy", otherwise it is "Sell"
  1255. Private Sub DetermineDealType(ByRef WS As Worksheet, ByRef ExchangeRate() As Double, ByRef dealType() As String)
  1256.     Dim i As Long, j As Long
  1257.     Dim posSell As Long, posBuy As Long, cnt As Long
  1258.     Dim f As Boolean
  1259.    
  1260.     Call RecalculateExchangeRates(WS, 1, ExchangeRate, 3)
  1261.     For i = 1 To numberOfExchanges
  1262.         If i > 1 And exchanges(i).Day <> exchanges(i - 1).Day Then
  1263.             Call RecalculateExchangeRates(WS, i, ExchangeRate)
  1264.         End If
  1265.        
  1266.         If exchanges(i).CurrencyNumber <> 0 Then
  1267.             If True Then
  1268.                 If exchanges(i).Amount(1) < 0 And exchanges(i).Amount(2) <= 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
  1269.                     exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
  1270.                     exchanges(i).Amount(1) = 0
  1271.                 End If
  1272.                 If exchanges(i).Amount(1) <> 0 And exchanges(i).Amount(2) <> 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
  1273.                     If (DoubleAbs((exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)) / exchanges(i).Amount(2)) < 0.1) Then
  1274.                         exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
  1275.                         exchanges(i).Amount(1) = 0
  1276.                     End If
  1277.                 End If
  1278.                 If exchanges(i).Amount(1) <> 0 And exchanges(i).Amount(2) <> 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
  1279.                     f = False
  1280.                     For j = 3 To 12
  1281.                         If exchanges(i).Amount(j) <> 0 Then f = True
  1282.                     Next j
  1283.                     If f Then
  1284.                         exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
  1285.                         exchanges(i).Amount(1) = 0
  1286.                     End If
  1287.                 End If
  1288.                 If exchanges(i).Amount(1) > 0 And exchanges(i).Amount(2) >= 0 And getExchangeRate(WS, i, 2, 1, ExchangeRate) <> -1 Then
  1289.                     exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(1) * getExchangeRate(WS, i, 2, 1, ExchangeRate)
  1290.                     exchanges(i).Amount(1) = 0
  1291.                 End If
  1292.             End If
  1293.             posSell = 0
  1294.             posBuy = 0
  1295.             cnt = 0
  1296.             For j = 1 To 12
  1297.                 If exchanges(i).Amount(j) <> 0 Then
  1298.                     cnt = cnt + 1
  1299.                     If exchanges(i).Amount(j) < 0 Then
  1300.                         posSell = j
  1301.                     Else
  1302.                         posBuy = j
  1303.                     End If
  1304.                 End If
  1305.             Next j
  1306.            
  1307.             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
  1308.                 If getExchangeRate(WS, i, 2, 3, ExchangeRate) <> -1 Then
  1309.                     exchanges(i).Amount(2) = exchanges(i).Amount(2) + exchanges(i).Amount(3) * getExchangeRate(WS, i, 2, 3, ExchangeRate)
  1310.                     exchanges(i).Amount(3) = 0
  1311.                 End If
  1312.             End If
  1313.             If cnt <> 2 Then
  1314.                 posSell = 0
  1315.                 posBuy = 0
  1316.                 cnt = 0
  1317.                 For j = 1 To 12
  1318.                     If exchanges(i).Amount(j) <> 0 Then
  1319.                         cnt = cnt + 1
  1320.                         If exchanges(i).Amount(j) < 0 Then
  1321.                             posSell = j
  1322.                         Else
  1323.                             posBuy = j
  1324.                         End If
  1325.                     End If
  1326.                 Next j
  1327.             End If
  1328.             If cnt = 2 Then
  1329.                 If posSell > 7 And posBuy > 7 Then
  1330.                     If posSell = 8 Or posSell = 14 Or posSell = 16 Then
  1331.                         exchanges(i).BuyOrSell = "Buy"
  1332.                         dealType(i) = "Buy"
  1333.                     Else
  1334.                         exchanges(i).BuyOrSell = "Sell"
  1335.                         dealType(i) = "Sell"
  1336.                     End If
  1337.                 Else
  1338.                     If posSell <= 7 And posBuy <= 7 Then
  1339.                         If posSell = 5 Then
  1340.                             exchanges(i).BuyOrSell = "Buy"
  1341.                             dealType(i) = "Buy"
  1342.                         Else
  1343.                             exchanges(i).BuyOrSell = "Sell"
  1344.                             dealType(i) = "Sell"
  1345.                         End If
  1346.                     Else
  1347.                         If posSell = 5 Or posSell = 7 Then
  1348.                             exchanges(i).BuyOrSell = "Buy"
  1349.                             dealType(i) = "Buy"
  1350.                         Else
  1351.                             exchanges(i).BuyOrSell = "Sell"
  1352.                             dealType(i) = "Sell"
  1353.                         End If
  1354.                     End If
  1355.                 End If
  1356.             End If
  1357.         End If
  1358.     Next i
  1359. End Sub
  1360.  
  1361. 'Function that controls calls of auxiliary functions
  1362. 'The result of evaluation is calculated profits and perfect look of the table
  1363. Private Sub CalculateProfit(ByRef WS As Worksheet, ByVal buttonName As String)
  1364.     Dim i, j, numberOfLines As Long
  1365.     numberOfLines = calculateNumberOfLines(WS)
  1366.     Dim ansectorInDSU(5000), sz(5000) As Long
  1367.     Dim ExchangeRate(13, 13), sumOfProfit(5000), dealBuySum(5000), dealSellSum(5000), exchangeOveralCirculation(5000) As Double
  1368.     Dim dealType(5000) As String
  1369.                
  1370.    
  1371.     For i = 0 To numberOfExchanges
  1372.         sumOfProfit(i) = 0
  1373.         dealBuySum(i) = 0
  1374.         dealSellSum(i) = 0
  1375.         ansectorInDSU(i) = i
  1376.         sz(i) = 1
  1377.         exchangeOveralCirculation(i) = 0
  1378.     Next i
  1379.    
  1380.     For i = 1 To 12
  1381.         For j = 1 To 12
  1382.             ExchangeRate(i, j) = -1
  1383.         Next j
  1384.     Next i
  1385.     Call DetermineDealType(WS, ExchangeRate, dealType)
  1386.    
  1387.     For i = 1 To 12
  1388.         For j = 1 To 12
  1389.             ExchangeRate(i, j) = -1
  1390.         Next j
  1391.     Next i
  1392.     Call DeleteEqual(WS, ansectorInDSU, sz, ExchangeRate)
  1393.     Call CalculateExchangeOveralCirculation(WS, exchangeOveralCirculation, ExchangeRate)
  1394.     For i = 1 To 12
  1395.         For j = 1 To 12
  1396.             ExchangeRate(i, j) = -1
  1397.         Next j
  1398.     Next i
  1399.     Call SuperDuper(WS, ExchangeRate, ansectorInDSU, sz, exchangeOveralCirculation)
  1400.     Call AddRest(WS, ExchangeRate)
  1401.     Call Init(WS, False, buttonName)
  1402.     Call LeaveOnlyMarked(WS)
  1403.     Call CalculateSummary(WS, ExchangeRate)
  1404.  
  1405.     For i = 3 To numberOfLines
  1406.         WS.Cells(i, 21).Value = WS.Cells(i, 22).Value
  1407.         WS.Cells(i, 22).Value = getInDSU(ansectorInDSU, i)
  1408.     Next i
  1409.     Call calculateSumOfProfit(WS, ExchangeRate, sumOfProfit)
  1410.     For i = 3 To numberOfLines
  1411.         If IsEmpty(WS.Cells(i, 22).Value) = False Then
  1412.             WS.Cells(i, 23).Value = sumOfProfit(WS.Cells(i, 22).Value)
  1413.         End If
  1414.     Next i
  1415.     Call calculateDealSum(WS, ExchangeRate, dealBuySum, dealSellSum, dealType)
  1416.     Call calculateBonusWithDealSum(WS, ExchangeRate, dealBuySum, dealSellSum, dealType)
  1417.     WS.Cells(1, 18).Value = "Ïðîôèò îïåðàöèè"
  1418.     WS.Cells(1, 19).Value = "Âàëþòà"
  1419.     WS.Cells(1, 20).Value = "% ïðîôèòà"
  1420.     WS.Cells(1, 21).Value = "¹ ñäåëêè"
  1421.     WS.Cells(1, 22).Value = "Ïðîôèò ñäåëêè"
  1422.     WS.Cells(1, 23).Value = "Áîíóñ"
  1423.     WS.Cells(1, 24).Value = "Àâòîð"
  1424.     For i = 1 To numberOfLines
  1425.         For j = 1 To 24
  1426.             WS.Cells(i, j).Borders.LineStyle = xlContinuous
  1427.         Next j
  1428.     Next i
  1429.     For i = 3 To numberOfLines
  1430.         Dim operationProfit As Double
  1431.         operationProfit = WS.Cells(i, 19).Value
  1432.         Dim currentCurrency As String
  1433.         currentCurrency = WS.Cells(i, 20).Value
  1434.         Dim person As String
  1435.         person = WS.Cells(i, 18).Value
  1436.         Dim ProfitPercentage As Double
  1437.         ProfitPercentage = WS.Cells(i, 21).Value
  1438.         Dim id As Long
  1439.         id = WS.Cells(i, 22).Value
  1440.         Dim sumOfDeal As Double
  1441.         sumOfDeal = WS.Cells(i, 23).Value
  1442.         Dim bonus As Double
  1443.         bonus = WS.Cells(i, 24).Value
  1444.  
  1445.         For j = 18 To 24
  1446.             WS.Cells(i, j).ClearContents
  1447.         Next j
  1448.         WS.Cells(i, 18).Value = CDbl(operationProfit)
  1449.         WS.Cells(i, 18).NumberFormat = "0.00"
  1450.         WS.Cells(i, 19).Value = currentCurrency
  1451.         WS.Cells(i, 20).Value = CDbl(ProfitPercentage)
  1452.         WS.Cells(i, 20).NumberFormat = "0.00"
  1453.         WS.Cells(i, 21).Value = id
  1454.         WS.Cells(i, 22).Value = CDbl(sumOfDeal)
  1455.         WS.Cells(i, 22).NumberFormat = "0.00"
  1456.         WS.Cells(i, 23).Value = CDbl(bonus)
  1457.         WS.Cells(i, 23).NumberFormat = "0.00"
  1458.         WS.Cells(i, 24).Value = person
  1459.     Next i
  1460.  
  1461.     Dim lastLine As Long
  1462.     lastLine = printBonus(WS)
  1463.  
  1464.     Dim used(5000) As Boolean, sumOverDeals(20) As Double
  1465.     For i = 4 To 17
  1466.         sumOverDeals(i) = 0
  1467.     Next i
  1468.     For i = 3 To numberOfLines
  1469.         If (WS.Cells(i, 24).Value = "ë" And used(WS.Cells(i, 21).Value) = False) Then
  1470.             used(WS.Cells(i, 21).Value) = True
  1471.             For j = 5 To 17
  1472.                 If (WS.Cells(1, j).Value = WS.Cells(i, 19).Value) Then
  1473.                     sumOverDeals(j) = sumOverDeals(j) + WS.Cells(i, 22).Value
  1474.                 End If
  1475.             Next j
  1476.         End If
  1477.     Next i
  1478.  
  1479.     WS.Cells(lastLine + 1, 4).Value = "Ïðèáûëü ïî ñäåëêàì ñ ó÷àñòèåì Ë"
  1480.     For j = 5 To 17
  1481.         WS.Cells(lastLine + 1, j).Value = sumOverDeals(j)
  1482.     Next j
  1483.     For j = 4 To 17
  1484.         WS.Cells(lastLine + 1, j).Interior.Color = vbYellow
  1485.     Next j
  1486.  
  1487.     For i = 4 To 17
  1488.         sumOverDeals(i) = 0
  1489.     Next i
  1490.     For i = 3 To numberOfLines
  1491.         If (WS.Cells(i, 24).Value = "þ" And used(WS.Cells(i, 21).Value) = True) Then
  1492.             used(WS.Cells(i, 21).Value) = False
  1493.             For j = 5 To 17
  1494.                 If (WS.Cells(1, j).Value = WS.Cells(i, 19).Value) Then
  1495.                     sumOverDeals(j) = sumOverDeals(j) + WS.Cells(i, 22).Value
  1496.                 End If
  1497.             Next j
  1498.         End If
  1499.     Next i
  1500.  
  1501.     WS.Cells(lastLine + 2, 4).Value = "Ïðèáûëü ïî ñäåëêàì ñ ó÷àñòèåì Þ"
  1502.     For j = 5 To 17
  1503.         WS.Cells(lastLine + 2, j).Value = sumOverDeals(j)
  1504.     Next j
  1505.     For j = 4 To 17
  1506.         WS.Cells(lastLine + 2, j).Interior.Color = RGB(255, 120, 200)
  1507.     Next j
  1508.  
  1509.     Dim firstLine As Long
  1510.     firstLine = lastLine
  1511.     Do While IsEmpty(WS.Cells(firstLine - 1, 4).Value) = False
  1512.         firstLine = firstLine - 1
  1513.     Loop
  1514.     Do While IsEmpty(WS.Cells(lastLine + 1, 4).Value) = False
  1515.         lastLine = lastLine + 1
  1516.     Loop
  1517.     For i = firstLine To lastLine - 1
  1518.         If (WS.Cells(i, 4).Interior.Color <> WS.Cells(i + 1, 4).Interior.Color) Then
  1519.             For j = i + 1 To lastLine
  1520.                 If (WS.Cells(i, 4).Interior.Color = WS.Cells(j, 4).Interior.Color) Then
  1521.                     Do While j <> i + 1
  1522.                         Dim k As Long
  1523.                         For k = 4 To 17
  1524.                             WS.Cells(firstLine, 3).Value = WS.Cells(j - 1, k).Value
  1525.                             WS.Cells(j - 1, k).Value = WS.Cells(j, k).Value
  1526.                             WS.Cells(j, k).Value = WS.Cells(firstLine, 3).Value
  1527.                             WS.Cells(firstLine, 3).NumberFormat = WS.Cells(j - 1, k).NumberFormat
  1528.                             WS.Cells(j - 1, k).NumberFormat = WS.Cells(j, k).NumberFormat
  1529.                             WS.Cells(j, k).NumberFormat = WS.Cells(firstLine, 3).NumberFormat
  1530.                             WS.Cells(firstLine, 3).Interior.Color = WS.Cells(j - 1, k).Interior.Color
  1531.                             WS.Cells(j - 1, k).Interior.Color = WS.Cells(j, k).Interior.Color
  1532.                             WS.Cells(j, k).Interior.Color = WS.Cells(firstLine, 3).Interior.Color
  1533.                         Next k
  1534.                         j = j - 1
  1535.                     Loop
  1536.                     Exit For
  1537.                 End If
  1538.             Next j
  1539.         End If
  1540.     Next i
  1541.     WS.Cells(firstLine, 3).Value = ""
  1542.     WS.Cells(firstLine, 3).Interior.Color = vbWhite
  1543.     'MsgBox numberOfLines
  1544.    numberOfLines = numberOfLines + 32
  1545.     If buttonName = "Daily revenue" Then
  1546.         For i = 3 To numberOfLines
  1547.             For j = 1 To 24
  1548.                 Call swapCells(WS, i, j, 3 * numberOfLines + i, j)
  1549.             Next j
  1550.         Next i
  1551.         j = 2
  1552.         For i = 3 To numberOfLines
  1553.             If i <> 3 And WS.Cells(3 * numberOfLines + i, 2).Value <> WS.Cells(j, 2).Value Then
  1554.                 j = j + 3
  1555.             Else
  1556.                 j = j + 1
  1557.             End If
  1558.             For k = 1 To 24
  1559.                 Call swapCells(WS, 3 * numberOfLines + i, k, j, k)
  1560.             Next k
  1561.         Next i
  1562.         For i = 3 To numberOfLines * 3
  1563.             If IsEmpty(WS.Cells(i, 1).Value) = False Then
  1564.                 Call RecalculateExchangeRates(WS, i, ExchangeRate)
  1565.                 j = i
  1566.                 Do While IsEmpty(WS.Cells(j + 1, 1).Value) = False
  1567.                     j = j + 1
  1568.                 Loop
  1569.                 WS.Cells(j + 1, 4).Value = "Sum in USD"
  1570.                 WS.Cells(j + 1, 7).Value = 0#
  1571.                 WS.Cells(j + 2, 4).Value = "Total profit in USD"
  1572.                 WS.Cells(j + 2, 7).Value = 0#
  1573.                 For k = i To j
  1574.                     Dim p As Long
  1575.                     If IsEmpty(WS.Cells(k, 18).Value) = False Then
  1576.                         For p = 5 To 17
  1577.                             If WS.Cells(1, p).Value = WS.Cells(k, 19).Value Then
  1578.                                 WS.Cells(j + 2, 7).Value = WS.Cells(j + 2, 7).Value + WS.Cells(k, 18).Value * getExchangeRate(WS, k, 7, p, ExchangeRate)
  1579.                             End If
  1580.                         Next p
  1581.                     End If
  1582.                     For p = 5 To 17
  1583.                         If p = 6 Then p = 7
  1584.                         If IsEmpty(WS.Cells(k, p).Value) = False Then
  1585.                             WS.Cells(j + 1, 7).Value = WS.Cells(j + 1, 7).Value + WS.Cells(k, p).Value * getExchangeRate(WS, k, 7, p, ExchangeRate)
  1586.                         End If
  1587.                     Next p
  1588.                 Next k
  1589.                 i = j
  1590.             End If
  1591.         Next i
  1592.     End If
  1593. End Sub
  1594.  
  1595. Private Sub swapCells(ByRef WS As Worksheet, ByVal i As Long, ByVal j As Long, ByVal iTo As Long, ByVal jTo As Long)
  1596.     WS.Cells(1, 50).Value = WS.Cells(i, j).Value
  1597.     WS.Cells(1, 50).Interior.Color = WS.Cells(i, j).Interior.Color
  1598.     WS.Cells(1, 50).NumberFormat = WS.Cells(i, j).NumberFormat
  1599.     WS.Cells(1, 50).Borders.LineStyle = WS.Cells(i, j).Borders.LineStyle
  1600.    
  1601.     WS.Cells(i, j).Value = WS.Cells(iTo, jTo).Value
  1602.     WS.Cells(i, j).Interior.Color = WS.Cells(iTo, jTo).Interior.Color
  1603.     WS.Cells(i, j).NumberFormat = WS.Cells(iTo, jTo).NumberFormat
  1604.     WS.Cells(i, j).Borders.LineStyle = WS.Cells(iTo, jTo).Borders.LineStyle
  1605.    
  1606.     WS.Cells(iTo, jTo).Value = WS.Cells(1, 50).Value
  1607.     WS.Cells(iTo, jTo).Interior.Color = WS.Cells(1, 50).Interior.Color
  1608.     WS.Cells(iTo, jTo).NumberFormat = WS.Cells(1, 50).NumberFormat
  1609.     WS.Cells(iTo, jTo).Borders.LineStyle = WS.Cells(1, 50).Borders.LineStyle
  1610.    
  1611.     'WS.Cells(1, 50).clear
  1612. End Sub
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top