Анализ эффективности вложений денежных средств в РКО

k = k + 1

Wend

Cells(Num; 1) = Sheet.Cells(k; 1)

Cells(Num; 2) = Sheet.Cells(k; 2)

Cells(Num; 3) = Sheet.Cells(k; 3)

Cells(Num; 1).HorizontalAlignment = xlLeft

Cells(Num; 2).HorizontalAlignment = xlCenter

Cells(Num; 3).HorizontalAlignment = xlCenter

Cells(Num; 3).WrapText = True

Num = Num + 1

End If

Next i

Cells(2; 1) = "за период от " + CStr(DateBegin) + " до " +

CStr(DateEnd)

Range(Cells(5; 1); Cells(Num - 1; 3)).Borders(xlLeft).Weight = xlThin

Range(Cells(5; 1); Cells(Num - 1; 3)).Borders(xlRight).Weight =

xlThin

Range(Cells(5; 1); Cells(Num - 1; 3)).Borders(xlTop).Weight = xlThin

Range(Cells(5; 1); Cells(Num - 1; 3)).Borders(xlBottom).Weight =

xlThin

Range(Cells(5; 1); Cells(Num - 1; 3)).BorderAround Weight:=xlMedium

Range(Cells(5; 2); Cells(Num - 1; 2)).BorderAround Weight:=xlMedium

Cells(Num + 2; 2) = "Ответственное лицо

Дилера______________________________"

With DialogSheets("ДиалогПечать")

AgainMonthOtch1:

Просмотр = False

ExitVar = False

Button = False

.Show

If Просмотр Then

Worksheets("СписокКлиентов").PrintPreview

GoTo AgainMonthOtch1

End If

If ExitVar Then Exit Sub

If Button Then ActiveWindow.SelectedSheets.PrintOut copies:=2

End With

End Sub

'-------------------------------- Перечисление/списание биржа ------

Sub GotoBirga()

Dim Sheet As Object

Dim OstIn; OstOut; OstBegin; CliNum As Double

Dim RowNum; k As Long

Dim DoFlag As Boolean

Set Sheet = Worksheets("ОстаткиБиржа")

Sheet.Range("B2").Sort Key1:=Sheet.Range("B2"); Order1:=xlAscending;

_

Key2:=Sheet.Range("A2");

Order2:=xlDescending; _

Header:=xlYes; OrderCustom:=1; _

MatchCase:=False; Orientation:=xlTopToBottom

Sheet.Select

CurDate = Worksheets("Врем").Cells(1; 4)

k = 2

While Worksheets("Клиенты").Cells(k; 1) <> Empty

k = k + 1

Wend

With DialogSheets("ДиалогБиржа")

.DropDowns.ListFillRange = "Клиенты!$B$2:$B$" + CStr(k - 1)

.EditBoxes(1).InputType = xlNumber

.EditBoxes(2).InputType = xlNumber

.Show

If Button = False Then

MsgBox "Данные не занесены"

Exit Sub

End If

CliNum = .DropDowns(1).List(.DropDowns(1).ListIndex)

If .EditBoxes(1).Text = "" Then

OstIn = 0

Else

OstIn = .EditBoxes(1).Text

End If

If .EditBoxes(2).Text = "" Then

OstOut = 0

Else

OstOut = .EditBoxes(2).Text

End If

OstBegin = 0

k = 2

DoFlag = True

Do While Cells(k; 1) <> Empty

If Cells(k; 2) = CliNum And DoFlag Then

If Cells(k; 1) < CurDate Then

OstBegin = Cells(k; 6)

Else

MsgBox "Невозможен ввод информации"

Exit Sub

End If

DoFlag = False

End If

k = k + 1

Loop

Cells(k; 1) = CurDate

Cells(k; 2) = CliNum

Cells(k; 3) = OstBegin

Cells(k; 4) = OstIn

Cells(k; 5) = OstOut

Cells(k; 6) = OstBegin + OstIn - OstOut

End With

End Sub

'-------------------------------- Просмотр остатков 812 ------------

Sub PrintOst()

Dim Sheet; Sheet1 As Object

Dim i; k; CliNum As Long

Dim Ost As Double

CurDate = Worksheets("Врем").Cells(1; 4)

i = 2

While Worksheets("Сделки").Cells(i; 1) <> Empty

If Worksheets("Сделки").Cells(i; 1) = CurDate Then

Call EditOstBirga(Worksheets("Сделки").Cells(i; 2))

End If

i = i + 1

Wend

Set Sheet = Worksheets("Остатки812")

Set Sheet1 = Worksheets("ОстаткиБиржа")

Sheets("Клиенты").Select

i = 2

Sheet.Range("B2").Sort Key1:=Sheet.Range("B2"); Order1:=xlAscending;

_

Key2:=Sheet.Range("A2");

Order2:=xlDescending; _

Header:=xlYes; OrderCustom:=1; _

MatchCase:=False; Orientation:=xlTopToBottom

Sheet1.Range("B2").Sort Key1:=Sheet1.Range("B2");

Order1:=xlAscending; _

Key2:=Sheet1.Range("A2");

Order2:=xlDescending; _

Header:=xlYes; OrderCustom:=1; _

MatchCase:=False; Orientation:=xlTopToBottom

While Cells(i; 2) <> Empty

CliNum = Cells(i; 2)

k = 2

Do

If Sheet.Cells(k; 1) = Empty Then

Ost = 0

Exit Do

End If

If Sheet.Cells(k; 2) = CliNum Then

Ost = Sheet.Cells(k; 8)

Exit Do

End If

k = k + 1

Loop

Cells(i; 4) = Ost

k = 2

Do

If Sheet1.Cells(k; 1) = Empty Then

Ost = 0

Exit Do

End If

If Sheet1.Cells(k; 2) = CliNum Then

Ost = Sheet1.Cells(k; 6)

Exit Do

End If

k = k + 1

Loop

Cells(i; 5) = Ost

i = i + 1

Wend

End Sub

'-------------------------------- Печать портфель ------------------

Sub PrintPortfel()

Dim Sheet As Object

Dim i; k; BumNum; m As Long

Dim Bum(ConstMaxBum); DatePog(ConstMaxBum) As Long

Dim Volume(); BiginIndex(); dates(); V() As Integer

Dim Price(); BumPrice(); DohPog(); DohPriobr() As Double

Dim DateMas() As Date

Dim Flag; BumIndex() As Boolean

Dim SumPog1(); SumPog2(); SumPriobr1(); SumPriobr2() As Double

Dim SumPog11; SumPriobr11; SumPog22; SumPriobr22 As Double

Dim BumVol() As Integer

Dim AllVol As Long

Dim PortfelCost; PortfelBalance As Double

CurDate = Worksheets("Врем").Cells(1; 4)

Set Sheet = Worksheets("Бумаги")

i = 2

BumNum = 0

While Sheet.Cells(i; 1) <> Empty

If (Sheet.Cells(i; 2) CurDate)

Then

Bum(BumNum + 1) = Sheet.Cells(i; 1)

DatePog(BumNum + 1) = Sheet.Cells(i; 3)

BumNum = BumNum + 1

End If

i = i + 1

Wend

Worksheets("Сделки").Select

Range("B2").Sort Key1:=Range("A2"); Order1:=xlAscending; _

Key2:=Range("D2"); Order2:=xlAscending; _

Header:=xlYes; OrderCustom:=1; _

MatchCase:=False; Orientation:=xlTopToBottom

ReDim Volume(BumNum; MaxCount)

ReDim Price(BumNum; MaxCount)

ReDim DateMas(BumNum; MaxCount)

ReDim DohPog(BumNum; MaxCount)

ReDim DohPriobr(BumNum; MaxCount)

ReDim dates(BumNum); V(BumNum); BeginIndex(BumNum)

ReDim BumIndex(BumNum); BumPrice(BumNum)

ReDim SumPog1(BumNum); SumPog2(BumNum); SumPriobr1(BumNum);

SumPriobr2(BumNum)

ReDim BumVol(BumNum)

For i = 1 To BumNum

dates(i) = 1

Next i

i = 2

While Cells(i; 1) <> Empty

If Cells(i; 2) = DilerConst And Cells(i; 7) <> "списание" _

And Cells(i; 7) <> "зачисление" Then

Flag = True

For k = 1 To BumNum ' поиск номера бумаги

If Cells(i; 3) = Bum(k) Then

Flag = False

Exit For

End If

Next k

If Flag Then GoTo cont

If Cells(i; 1) Volume(k; i) Then

V(k) = V(k) - Volume(k; i)

Else

Volume(k; i) = V(k)

BeginIndex(k) = i

Exit For

End If

Next i

Next k

For k = 1 To BumNum

BumIndex(k) = False

If V(k) > 0 Then BumIndex(k) = True

Next k

i = 2

While Cells(i; 1) Empty

If (Cells(i; 1) = CurDate And Cells(i; 2) = DilerConst) _

And (Cells(i; 7) <> "зачисление" And Cells(i; 7) <> "списание")

Then

For k = 1 To BumNum

If Cells(i; 3) = Bum(k) Then

BumIndex(k) = True

End If

Next k

End If

i = i + 1

Wend

i = 2

Set Sheet = Worksheets("Биржа")

Flag = True

While Sheet.Cells(i; 1) <> Empty

If Sheet.Cells(i; 1) = CurDate Then

Flag = False

For k = 1 To BumNum

If Sheet.Cells(i; 2) = Bum(k) Then

If Sheet.Cells(i; 6) > 0 Then

BumPrice(k) = Sheet.Cells(i; 6)

Else

BumPrice(k) = 0

End If

End If

Next k

End If

i = i + 1

Wend

If Flag Then

MsgBox "Биржевой информации нет. Портфель сформировать невозможно."

Exit Sub

End If

Worksheets("Портфель1").Select

Cells(4; 3) = CurDate

Range("A7:H200").Delete shift:=xlToLeft

m = 7

PortfelCost = 0

PortfelBalance = 0

For k = 1 To BumNum

If Volume(k; BeginIndex(k)) > 0 Then

For i = BeginIndex(k) To dates(k)

If Volume(k; i) > 0 Then

Cells(m; 1) = Bum(k)

Cells(m; 1).NumberFormat = "0"

Cells(m; 2) = DateMas(k; i)

Cells(m; 2).NumberFormat = "ДД.ММ.ГГ"

Cells(m; 3) = Price(k; i)

Cells(m; 3).NumberFormat = "0,00"

Cells(m; 4) = Volume(k; i)

Cells(m; 4).NumberFormat = "0"

DohPog(k; i) = (100 / Price(k; i) - 1) * 36500 / (DatePog(k) -

DateMas(k; i))

Cells(m; 5) = DohPog(k; i)

Cells(m; 5).NumberFormat = "0,00"

Cells(m; 8).NumberFormat = "0"

Dim tmp As Long

tmp = CurDate - DateMas(k; i)

Cells(m; 8) = tmp

PortfelBalance = PortfelBalance + Price(k; i) * Volume(k; i)

If BumPrice(k) > 0 Then

PortfelCost = PortfelCost + BumPrice(k) * Volume(k; i)

Else

PortfelCost = PortfelCost + Price(k; i) * Volume(k; i)

End If

If BumPrice(k) > 0 Then

Cells(m; 6) = BumPrice(k)

Cells(m; 6).NumberFormat = "0,00"

If CurDate <> DateMas(k; i) Then

DohPriobr(k; i) = (BumPrice(k) / Price(k; i) - 1) * 36500 /

(CurDate - DateMas(k; i))

Cells(m; 7) = DohPriobr(k; i)

Cells(m; 7).NumberFormat = "0,00"

End If

End If

m = m + 1

End If

Next i

Range(Cells(m; 1); Cells(m; 8)).Interior.ColorIndex = 15

m = m + 1

End If

Next k

Range(Cells(7; 1); Cells(m - 1; 8)).Borders(xlLeft).Weight = xlThin

Range(Cells(7; 1); Cells(m - 1; 8)).Borders(xlRight).Weight = xlThin

Range(Cells(7; 1); Cells(m - 1; 8)).Borders(xlTop).Weight = xlThin

Range(Cells(7; 1); Cells(m - 1; 8)).Borders(xlBottom).Weight = xlThin

Range(Cells(7; 1); Cells(m - 1; 8)).BorderAround Weight:=xlMedium

If DialogPrint("Портфель1"; 1) Then Exit Sub

Worksheets("Портфель2").Select

Cells(4; 3) = CurDate

SumPog11 = 0

SumPog22 = 0

SumPriobr11 = 0

SumPriobr22 = 0

AllVol = 0

m = 7

Range("A7:H200").Delete shift:=xlToLeft

For k = 1 To BumNum

If Volume(k; BeginIndex(k)) > 0 Then

SumPog1(k) = 0

SumPog2(k) = 0

SumPriobr1(k) = 0

SumPriobr2(k) = 0

BumVol(k) = 0

For i = BeginIndex(k) To dates(k)

If Volume(k; i) > 0 Then

SumPog1(k) = SumPog1(k) + DohPog(k; i) * Volume(k; i) *

(DatePog(k) - DateMas(k; i))

SumPog2(k) = SumPog2(k) + Volume(k; i) * (DatePog(k) - DateMas(k;

i))

If CurDate <> DateMas(k; i) Then

SumPriobr1(k) = SumPriobr1(k) + DohPriobr(k; i) * Volume(k; i) *

(CurDate - DateMas(k; i))

SumPriobr2(k) = SumPriobr2(k) + Volume(k; i) * (CurDate -

DateMas(k; i))

End If

SumPog11 = SumPog11 + SumPog1(k)

SumPog22 = SumPog22 + SumPog2(k)

SumPriobr11 = SumPriobr11 + SumPriobr1(k)

SumPriobr22 = SumPriobr22 + SumPriobr2(k)

BumVol(k) = BumVol(k) + Volume(k; i)

AllVol = AllVol + Volume(k; i)

End If

Next i

Cells(m; 1) = Bum(k)

Cells(m; 1).NumberFormat = "0"

Cells(m; 2) = BumVol(k)

Cells(m; 2).NumberFormat = "0"

Cells(m; 3) = SumPog1(k) / SumPog2(k)

Cells(m; 3).NumberFormat = "0,00"

If SumPriobr2(k) > 0 And SumPriobr1(k) > 0 Then

Cells(m; 4) = SumPriobr1(k) / SumPriobr2(k)

Cells(m; 4).NumberFormat = "0,00"

End If

m = m + 1

End If

Next k

Cells(m; 1) = "Итого"

Cells(m; 1).Font.Bold = True

Cells(m; 1).HorizontalAlignment = xlCenter

Cells(m; 2) = AllVol

Cells(m; 2).NumberFormat = "0"

Cells(m; 3) = SumPog11 / SumPog22

Cells(m; 3).NumberFormat = "0,00"

Cells(m; 4) = SumPriobr11 / SumPriobr22

Cells(m; 4).NumberFormat = "0,00"

Range(Cells(m; 1); Cells(m; 4)).Interior.ColorIndex = 15

Range(Cells(7; 1); Cells(m; 4)).Borders(xlLeft).Weight = xlThin

Range(Cells(7; 1); Cells(m; 4)).Borders(xlRight).Weight = xlThin

Range(Cells(7; 1); Cells(m; 4)).Borders(xlTop).Weight = xlThin

Range(Cells(7; 1); Cells(m; 4)).Borders(xlBottom).Weight = xlThin

Range(Cells(7; 1); Cells(m; 4)).BorderAround Weight:=xlMedium

Range(Cells(m; 1); Cells(m; 4)).BorderAround Weight:=xlMedium

Cells(m + 1; 1) = "Стоимость портфеля по балансу"

Cells(m + 2; 1) = "Текущая стоимость потфеля"

Cells(m + 1; 1).Font.Bold = True

Cells(m + 2; 1).Font.Bold = True

Range(Cells(m + 1; 1); Cells(m + 2; 4)).BorderAround Weight:=xlMedium

Cells(m + 1; 4) = PortfelBalance * 10

Cells(m + 1; 4).NumberFormat = "### ### ###,00"

Cells(m + 1; 4).Font.Bold = True

Cells(m + 2; 4) = PortfelCost * 10

Cells(m + 2; 4).NumberFormat = "### ### ###,00"

Cells(m + 2; 4).Font.Bold = True

If DialogPrint("Портфель2"; 1) Then Exit Sub

End Sub

'-------------------------------- Печать Журнала лицевого учета -------

--

Sub PrintMagazine()

Dim Sheet As Object

Dim i; k; BumNum; m; m1; j As Long

Dim Bum(ConstMaxBum) As Long

Dim Volume(); BiginIndex(); dates(); V(); Vol As Integer

Dim sum; Price() As Double

Dim DateMas() As Date

Dim Flag; BumIndex() As Boolean

Dim ComBirga; ComMas(); MagMas(); Mag(4) As Double

CurDate = Worksheets("Врем").Cells(1; 4)

i = 2

Flag = True

Do While Worksheets("Сделки").Cells(i; 1) <> Empty

If Worksheets("Сделки").Cells(i; 1) = CurDate And _

Worksheets("Сделки").Cells(i; 2) = DilerConst Then

Flag = False

Exit Do

End If

i = i + 1

Loop

If Flag Then

MsgBox "Сделок в текущий день не было"

Exit Sub

End If

Set Sheet = Worksheets("Бумаги")

i = 2

BumNum = 0

While Sheet.Cells(i; 1) <> Empty

If (Sheet.Cells(i; 2) = CurDate)

Then

Bum(BumNum + 1) = Sheet.Cells(i; 1)

BumNum = BumNum + 1

End If

i = i + 1

Wend

Worksheets("Сделки").Select

Range("B2").Sort Key1:=Range("A2"); Order1:=xlAscending; _

Key2:=Range("D2"); Order2:=xlAscending; _

Header:=xlYes; OrderCustom:=1; _

MatchCase:=False; Orientation:=xlTopToBottom

ReDim Volume(BumNum; MaxCount)

ReDim Price(BumNum; MaxCount)

ReDim DateMas(BumNum; MaxCount)

ReDim dates(BumNum); V(BumNum); BeginIndex(BumNum)

ReDim BumIndex(BumNum); ComMas(BumNum)

ReDim MagMas(BumNum; 4)

For i = 1 To BumNum

ComMas(i) = 0

dates(i) = 1

Next i

i = 2

While Cells(i; 1) <> Empty And CurDate > Cells(i; 1)

If Cells(i; 2) = DilerConst And Cells(i; 7) <> "списание" _

And Cells(i; 7) <> "зачисление" Then

Flag = True

For k = 1 To BumNum ' поиск номера бумаги

If Cells(i; 3) = Bum(k) Then

Flag = False

Exit For

End If

Next k

If Flag Then GoTo cont

If Not IsEmpty(Cells(i; 4)) Then

Volume(k; dates(k)) = Cells(i; 6)

Price(k; dates(k)) = Cells(i; 4)

DateMas(k; dates(k)) = Cells(i; 1)

dates(k) = dates(k) + 1

V(k) = V(k) + Cells(i; 6)

Else

V(k) = V(k) - Cells(i; 6)

End If

End If

cont:

i = i + 1

Wend

For k = 1 To BumNum

For i = dates(k) To 1 Step -1

If V(k) > Volume(k; i) Then

V(k) = V(k) - Volume(k; i)

Else

Volume(k; i) = V(k)

BeginIndex(k) = i

Exit For

End If

Next i

Next k

For k = 1 To BumNum

BumIndex(k) = False

If V(k) > 0 Then BumIndex(k) = True

Next k

ComBirga = Worksheets("Инфо").Cells(1; 2)

i = 2

While Cells(i; 1) <> Empty

If (Cells(i; 1) = CurDate And Cells(i; 2) = DilerConst) _

And (Cells(i; 7) <> "зачисление" And Cells(i; 7) <> "списание")

Then

For k = 1 To BumNum

If Cells(i; 3) = Bum(k) Then

BumIndex(k) = True

If Not IsEmpty(Cells(i; 4)) Then

ComMas(k) = ComMas(k) + Format(Cells(i; 4) * Cells(i; 6) *

ComBirga * 0,1 + 0,0001; "0,00")

Else

If Cells(i; 5) <> 100 Then

ComMas(k) = ComMas(k) + Format(Cells(i; 5) * Cells(i; 6) *

Страницы: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10