Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- '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
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement