SHARE
TWEET

Untitled

a guest Sep 19th, 2019 95 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. '-------------------------------------------------SOME HELPFUL FUNCTIONS--------------------------------------------
  6. Function Inc(ByRef val As Variant, Optional ByVal add As Variant = 1) As Variant
  7.     val = val + add
  8.     Inc = val
  9. End Function
  10.  
  11. Sub DelButtons(ByRef WS As Worksheet)
  12.     Dim btn As Shape
  13.     For Each btn In WS.Shapes
  14.         If btn.AutoShapeType = msoShapeStyleMixed Then btn.Delete
  15.     Next
  16. End Sub
  17. '-------------------------------------------------------------------------------------------------------------------
  18.  
  19. '-------------------------------------------------MY OWN TYPES------------------------------------------------------
  20. Public Type Manager
  21.     NickName As String          'manager's name which is used to mark him in a table
  22.    RealName As String          'name to display in statistics
  23.    City As String              'city where manager works
  24. End Type
  25.  
  26. Private Type Exchange
  27.     ExchangeType As String      'обмен | расход | доход
  28.    Day As String               'the day when exchange took place
  29.    ProjectName As String       '
  30.    Description As String       '
  31.    Amount(17) As Double        'the amount of each currency (1-index)
  32.    ExchangeRate As Double      'the number from table
  33.    Manager As Long             'the person who made exchange
  34.    BuyOrSell As String         'Buy cryptocurrency or Sell cryptocurrency
  35.    Pair As Long                'the number of almost equal exchange (or -1 if none)
  36.    Profit As Double            'profit of exchange
  37.    CurrencyNumber As Long      'profit currency number
  38.    ProfitPercentage As Double  '
  39.    DealNumber As Long          'the number of deal which's part this exchange is
  40.    Errors As String            '
  41. End Type
  42. '-------------------------------------------------------------------------------------------------------------------
  43.  
  44. '-------------------------------------------------GLOBAL VARIABLES--------------------------------------------------
  45. Dim numberOfManagers            '
  46. Dim numberOfExchanges As Long   'number of good exchanges from the month
  47. Dim managers(4) As Manager      '
  48. Dim currencyNames(16)           'currency names
  49. Dim monthToCalculate As String  'the month for which script calculates bonuses
  50. Dim exchanges() As Exchange     'exchanges made in MonthToCalculate (1-index)
  51. Dim exchangesCopy() As Exchange '
  52. '-------------------------------------------------------------------------------------------------------------------
  53.  
  54.  
  55. Sub CalculateBonusMacros()
  56.     Application.ScreenUpdating = False
  57.     Dim WS As Worksheet
  58.     If Init(WS, True, "Bonus") Then
  59.         Call CalculateProfit(WS, "Bonus")
  60.     End If
  61.     Application.ScreenUpdating = True
  62. End Sub
  63.  
  64. Sub CalculateDailyRevenueMacros()
  65.     Application.ScreenUpdating = False
  66.     Dim WS As Worksheet
  67.     If Init(WS, True, "Daily revenue") Then
  68.         Call CalculateProfit(WS, "Daily revenue")
  69.     End If
  70.     Application.ScreenUpdating = True
  71. End Sub
  72.  
  73. Sub InitManager(NickName As String, RealName As String, City As String)
  74.     Inc numberOfManagers
  75.     With Manager(numberOfManagers)
  76.         .NickName = NickName
  77.         .RealName = RealName
  78.         .City = City
  79.     End With
  80. End Sub
  81.  
  82. Function TableHasBadInformation() As Boolean
  83.     Dim i, j, k, cnt, cntNegative, cntPositive, cntErrors As Long
  84.     Dim cntErrors As Long
  85.    
  86.     If IsEmpty(Cells(1, 18).Value) Then
  87.         MsgBox "Введите месяц"
  88.         TableHasBadInformation = True
  89.         Exit Function
  90.     End If
  91.        
  92.     cntErrors = 0
  93.     For i = 3 To Rows.Count
  94.         If IsEmpty(Cells(i, 1).Value) Then
  95.             Exit For
  96.         End If
  97.         If GoodDay(Cells(i, 2).Value) = False Then Next i
  98.         If Cells(i, 1).Value = "обмен" And Cells(i, 4).Value <> "Неучтенный доход" And Cells(i, 4).Value <> "Неучтенный расход" And Cells(i, 1).Interior.Color <> vbRed Then
  99.             cnt = 0
  100.             cntPositive = 0
  101.             cntNegative = 0
  102.             For k = 5 To 17
  103.                 If k <> 6 And IsEmpty(Cells(i, k).Value) = False Then
  104.                     If Cells(i, k).Value <> 0 Then cnt = cnt + 1
  105.                     If Cells(i, k).Value > 0 Then cntPositive = cntPositive + 1
  106.                     If Cells(i, k).Value < 0 Then cntNegative = cntNegative + 1
  107.                 End If
  108.             Next k
  109.             If cnt >= 2 And cntPositive > 0 And cntNegative > 0 And GoodDay(ActiveSheet, Cells(i, 2).Value) Then
  110.                 For k = 1 To 18
  111.                     If IsEmpty(Cells(i, k).Value) = False And IsNumeric(Cells(i, k).Value) = False And cntErrors < 5 And k > 4 And k < 18 Then
  112.                         Inc cntErrors
  113.                         MsgBox "Cell in line " & i & " column " & k & "(" & Cells(1, k).Value & ") contains something strange, expected number"
  114.                     End If
  115.                 Next k
  116.             End If
  117.         End If
  118.     Next i
  119.    
  120.     If cntErrors > 0 Then
  121.         MsgBox "script can't work with errors in the table"
  122.         TableHasBadInformation = True
  123.         Exit Function
  124.     End If
  125.    
  126.     TableHasBadInformation = False
  127. End Function
  128.  
  129. Function Init(ByRef WS As Worksheet, clear As Boolean, ByVal buttonName As String) As Boolean
  130.     Dim f As Boolean
  131.     Dim newSheetName, s As String
  132.     Dim i, j, k, cnt, cntNegative, cntPositive, cntErrors As Long
  133.    
  134.     If TableHasBadImformation Then
  135.         Init = False
  136.         Exit Function
  137.     End If
  138.    
  139.     Call InitManager("л", "Л", "Moscow")
  140.     Call InitManager("ю", "Ю", "Moscow")
  141.     Call InitManager("п", "П", "Moscow")
  142.        
  143.     k = 1
  144.     For j = 5 To 17
  145.         If j = 6 Then j = 7
  146.         currencyNames(k) = Cells(1, j).Value
  147.         Inc k
  148.     Next j
  149.  
  150.    
  151.     newSheetName = buttonName & " - " & Cells(1, 18).Value
  152.     'If There is already sheet with such name, then don't create a new sheet ...
  153.    f = False
  154.     For Each it In Sheets
  155.         If it.Name = newSheetName Then
  156.             Set WS = it
  157.             f = True
  158.             If clear Then WS.Cells.clear
  159.         End If
  160.     Next it
  161.     '... but if there not such sheet, then create a new one
  162.    If f = False Then
  163.         s = ActiveSheet.Name
  164.         Set WS = Sheets.add
  165.         WS.Name = newSheetName
  166.         Worksheets(s).Activate
  167.     End If
  168.  
  169.     WS.Visible = True
  170.  
  171.     Range("A1:R1").Copy WS.Range("A1:R1")
  172.     Range("E2:R2").Copy WS.Range("E2:R2")
  173.  
  174.     Call DelButtons(WS)
  175.  
  176.     monthToCalculate = Cells(1, 18).Value
  177.  
  178.     'Copy exchanges from the month
  179.    j = 1
  180.     Do While IsEmpty(Cells(j, 1).Value) = False
  181.         If GoodDay(Cells(i, 2).Value) Then Inc j
  182.     Loop
  183.     ReDim exchanges(j)
  184.  
  185.     numberOfExchanges = 0
  186.     For i = 3 To Rows.Count
  187.         If IsEmpty(Cells(i, 1).Value) Then
  188.             Exit For
  189.         End If
  190.         If GoodDay(Cells(i, 2).Value) = False Then Next i
  191.         If Cells(i, 1).Value = "обмен" And Cells(i, 4).Value <> "Неучтенный доход" And Cells(i, 4).Value <> "Неучтенный расход" And Cells(i, 1).Interior.Color <> vbRed Then
  192.             cnt = 0
  193.             cntPositive = 0
  194.             cntNegative = 0
  195.             For k = 5 To 17
  196.                 If k <> 6 And IsEmpty(Cells(i, k).Value) = False Then
  197.                     With Cells(i, k)
  198.                         If .Value <> 0 Then Inc cnt
  199.                         If .Value > 0 Then Inc cntPositive
  200.                         If .Value < 0 Then Inc cntNegative
  201.                     End With
  202.                 End If
  203.             Next k
  204.             If cnt >= 2 And cntPositive > 0 And cntNegative > 0 Then
  205.                 Inc numberOfExchanges
  206.                 With exchanges(numberOfExchanges)
  207.                     .ExchangeType = WS.Cells(i, 1).Value
  208.                     .Day = WS.Cells(i, 2).Value
  209.                     .ProjectName = WS.Cells(i, 3).Value
  210.                     .Description = WS.Cells(i, 4).Value
  211.                     .ExchangeRate = IIf(IsEmpty(WS.Cells(i, 6).Vlaue), -1, WS.Cells(i, 6).Vlaue)
  212.                    
  213.                     k = 1
  214.                     For j = 5 To 17
  215.                         If j = 6 Then j = 7
  216.                         .Amount(k) = IIf(IsEmpty(WS.Cells(i, j).Value), 0, WS.Cells(i, j).Value)
  217.                         Inc k
  218.                     Next j
  219.                    
  220.                     .Manager = 0
  221.                     If IsEmpty(WS.Cells(i, 18).Value) = False Then
  222.                         For j = 1 To numberOfManagers
  223.                             If WS.Cells(i, 18).Value = Manager(j).NickName Then
  224.                                 .Manager = j
  225.                             End If
  226.                         Next j
  227.                     End If
  228.                    
  229.                     .BuyOrSell = ""
  230.                     .Pair = -1
  231.                     .Profit = 0#
  232.                     .CurrencyNumber = 0
  233.                     .ProfitPercentage = 0#
  234.                     .DealNumber = 0
  235.                     .Errors = ""
  236.                 End With
  237.             End If
  238.         End If
  239.     Next i
  240.     WS.Cells(1, 1).EntireColumn.AutoFit
  241.     WS.Cells(1, 2).EntireColumn.AutoFit
  242.     WS.Cells(1, 3).EntireColumn.AutoFit
  243.     WS.Cells(1, 4).EntireColumn.AutoFit
  244.     WS.Cells(1, 5).EntireColumn.AutoFit
  245.     'MsgBox "Init"
  246. End Function
  247.  
  248.  
  249. 'Function that controls calls of auxiliary functions
  250. 'The result of evaluation is calculated profits and perfect look of the table
  251. Private Sub CalculateProfit(ByRef WS As Worksheet, ByVal buttonName As String)
  252.  
  253. 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
Not a member of Pastebin yet?
Sign Up, it unlocks many cool features!
 
Top