Microsoft Office ( Word, Excel Visual Basic for Application). - (..)

( ).

: 100 500 1\%, 1000 2\%, 1500 3\% .. , 10\%. , , , . . , .

: , , , , - .

, ( ), .

:

.

1

3.5

.

0.5

2

 

1

0.4

3

.

0.5

1

1

4

 

7

.

120

.

368

125

35

110

.

340

100

:

: 35.12.

.

 

.

, .xls, ( . 5.). : , . , ( , ?) ().

. 5

, . . , .

. , .

.

( 7).

 

,

cApplicationState

, Excel .

frmMain

.

mMain

, , Excel .

WsMain

CommandButton .

wsReport

wsTest

, .

.

wsMain

 

Private Sub cmdStart_Click()

VvodTest

Raschet

End Sub

Private Sub cmdSetup_Click()

Rem MsgBox " 1.2!! 2003"

wsTest.Select

End Sub

 

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)

 

End Sub

Private Sub cmdQuit_Click()

Application.Quit

End Sub

 

VvodTest Raschet mMain.

 

mMain

'----------------------------------------

' ,

' Excel

'----------------------------------------

Dim mobjAppState As New cApplicationState

 

'----------------------------------------

'

'----------------------------------------

Public Const COMMANDBAR_NAME = ""

Public nPL As Integer ' -'

Public nSP As Integer ' '

Public nTC As Integer ' '

Public iPL As Integer ' -'

Public iSP As Integer ' '

Public iTC As Integer ' '

Public ProdTC() As String ' '

Public ProdPL() As String ' -'

Public PricePL() As Double ' -'

Public ProdSP() As String ' '

Public PriceSP () As Double ' '

Public NumTC () As Integer ' '

Public kTC() As Integer ' '

Public qTC() As Double ' '

 

Sub RestoreEnvironment()

'----------------------------------------

' Excel

'----------------------------------------

Application.ScreenUpdating = False

With mobjAppState

.RestoreState

End With

With Application.CommandBars("Worksheet Menu Bar")

.Reset

With .Controls

With .Add(msoControlButton)

. Caption = ""

.Style = msoButtonIconAndCaption

.OnAction = "SetEnvironment"

End With

End With

End With

With ThisWorkbook.Windows(1)

.DisplayWorkbookTabs = True

End With

DeleteCommandBar

With ActiveWindow

.DisplayHorizontalScrollBar = True

.DisplayVerticalScrollBar = True

.Caption = Empty

End With

End Sub

 

Sub SetEnvironment()

'----------------------------------------

' Excel

'

'----------------------------------------

wsMain.Select

With Application

. Caption = ""

. ScreenUPdating = False

End With

With mobjAppState

. Gestate

.HideAllCommandBars

End With

With Application

. DisplayFormulBar = False

.DisplayStatusBar = False

End With

ActiveWindow.Caption = ""

With ThisWorkbook.Windows(1)

.DisplayWorkbookTabs = False

End With

CreateCommandBar

ShowHome

End Sub

 

Sub CreateCommandBar()

'----------------------------------------

'

'----------------------------------------

Dim MenuBarBool As Boolean

MenuBarBool = True

DeleteCommandBar

With Application.CommandBars.Add(COMMANDBAR_NAME, msoBarTop, MenuBarBool, True)

.Visible = True

.Position = msoBarTop

.Protection = msoBarNoChangeVisible + msoBarNoCustomize

With .Controls

With .Add(msoControlButton)

.Caption = " "

.Style = msoButtonCaption

.OnAction = "RestoreEnvironment"

End With

End With

End With

End Sub

 

Sub DeleteCommandBar()

'----------------------------------------

'

'----------------------------------------

On Error Resume Next

Application.CommandBars(COMMANDBAR_NAME).Delete

End Sub

 

Sub ShowHome()

'----------------------------------------

'

'----------------------------------------

Application.ScreenUpdating = False

wsMain.Select

With ActiveWindow

Rem .DisplayHorizontalScrollBar = False

Rem .DisplayVerticalScrollBar = False

End With

End Sub

Sub VvodTest()

' '

nPL = 1

While (wsTest.Cells(nPL + 3, 2).Value <> 0)

nPL = nPL + 1

Wend

 

ReDim ProdPL(nPL) As String

ReDim PricePL(nPL) As Double

For iPL = 1 To nPL

ProdPL(iPL) = wsTest.Cells(iPL + 3, 1).Value

PricePL(iPL) = wsTest.Cells(iPL + 3, 2).Value

Next iPL

nSP = 1

While (wsTest.Cells(nSP + 3, 7).Value <> 0)

nSP = nSP + 1

Wend

ReDim ProdSP(nSP) As String

ReDim PriceSP(nSP) As Double

For iSP = 1 To nSP

ProdSP(iSP) = wsTest.Cells(iSP + 3, 6).Value

PriceSP(iSP) = wsTest.Cells(iSP + 3, 7).Value

Next iSP

nTC = 1

While (wsTest.Cells(nTC + 3, 14).Value <> 0)

nTC = nTC + 1

Wend

ReDim NumTC(nTC) As Integer

ReDim kTC(nTC) As Integer

ReDim ProdTC(nTC) As String

ReDim qTC(nTC) As Double

For iTC = 1 To nTC

NumTC(iTC) = wsTest.Cells(iTC + 3, 11).Value

kTC(iTC) = wsTest.Cells(iTC + 3, 12).Value

ProdTC(iTC) = wsTest.Cells(iTC + 3, 13).Value

qTC(iTC) = wsTest.Cells(iTC + 3, 14).Value

Next iTC

 

End Sub

Sub Raschet()

'

'

Dim nTC_N As Integer ' '

Dim iTC_N As Integer ' '

Dim nomTC_N As Integer ' '

Dim nomSP As Integer ' - '

Dim nomPL As Integer ' - '

Dim iPL As Integer ' -'

Dim iSP As Integer ' '

Dim iTC As Integer ' '

ReDim NumTC_N(nTC) As Integer ' '

ReDim SumTC_N(nTC) As Double ' '

ReDim Disc_TC(nTC) As Double ' '

ReDim kTC_N(nTC) As Integer ' '

Dim Perc As Integer ' '

Rem Dim Perc As Double

nTC_N = 0

For iTC = 1 To nTC

Rem NumTC (iTC) NumTC_N (nTC_N)

nomTC_N = 0

iTC_N = 1

While (iTC_N <= nTC_N) And (nomTC_N = 0)

If NumTC(iTC) = NumTC_N(iTC_N) Then nomTC_N = iTC_N Else iTC_N = iTC_N + 1

Wend

If nomTC_N = 0 Then

nTC_N = nTC_N + 1

NumTC_N(nTC_N) = NumTC(iTC)

kTC_N(nTC_N) = kTC(iTC)

If kTC(iTC) = 1 Then

Rem ProdTC (iTC) ProdSP (nSP)

nomSP = 0

iSP = 1

While (iSP <= nSP) And (nomSP = 0)

If ProdTC(iTC) = ProdSP(iSP) Then nomSP = iSP Else iSP = iSP + 1

Wend

If nomSP = 0 Then

Rem ProdTC (iTC) ProdPL (nPL)

nomPL = 0

iPL = 1

While (iPL <= nPL) And (nomPL = 0)

If ProdTC(iTC) = ProdPL(iPL) Then nomPL = iPL Else iPL = iPL + 1

Wend

If nomPL = 0 Then

Else

SumTC_N(nTC_N) = PricePL(nomPL) * qTC(iTC)

End If

Else

SumTC_N(nTC_N) = PriceSP(nomSP) * qTC(iTC)

End If

Else

Rem ProdTC (iTC) ProdPL (nPL)

nomPL = 0

iPL = 1

While (iPL <= nPL) And (nomPL = 0)

If ProdTC(iTC) = ProdPL(iPL) Then nomPL = iPL Else iPL = iPL + 1

Wend

If nomPL = 0 Then

Else

SumTC_N(nTC_N) = PricePL(nomPL) * qTC(iTC)

End If

End If

Else

If kTC(iTC) = 1 Then

Rem ProdTC (iTC) ProdSP (nSP)

nomSP = 0

iSP = 1

While (iSP <= nSP) And (nomSP = 0)

If ProdTC(iTC) = ProdSP(iSP) Then nomSP = iSP Else iSP = iSP + 1

Wend

If nomSP = 0 Then

Rem ProdTC (iTC) ProdPL (nPL)

nomPL = 0

iPL = 1

While (iPL <= nPL) And (nomPL = 0)

If ProdTC(iTC) = ProdPL(iPL) Then nomPL = iPL Else iPL = iPL + 1

Wend

If nomPL = 0 Then

Else

SumTC_N(nomTC_N) = SumTC_N(nomTC_N) + PricePL(nomPL) * qTC(iTC)

End If

Else

SumTC_N(nomTC_N) = SumTC_N(nomTC_N) + PriceSP(nomSP) * qTC(iTC)

End If

Else

Rem ProdTC (iTC) ProdPL (nPL)

nomPL = 0

iPL = 1

While (iPL <= nPL) And (nomPL = 0)

If ProdTC(iTC) = ProdPL(iPL) Then nomPL = iPL Else iPL = iPL + 1

Wend

If nomPL = 0 Then

Else

SumTC_N(nomTC_N) = SumTC_N(nomTC_N) + PricePL(nomPL) * qTC(iTC)

End If

End If

End If

Next iTC

 

Rem For iTC_N = 1 To nTC_N

Rem MsgBox SumTC_N(iTC_N)

Rem Next iTC_N

Rem

Disc_Sum = 0

For iTC_N = 1 To nTC_N

If SumTC_N(iTC_N) > 100 Then Perc = Int(SumTC_N(iTC_N) / 500) + 1 Else Perc = 0

If Perc > 10 Then Perc = 10

If kTC_N(iTC_N) = 1 Then Disc_TC(iTC_N) = 1.5 * Perc * SumTC_N(iTC_N) / 100 Else Disc_TC(iTC_N) = Perc * SumTC_N(iTC_N) / 100

Disc_Sum = Disc_Sum + Disc_TC(iTC_N)

 

Next iTC_N

wsReport.Select

Range("D15").Value = Disc_Sum

Rem MsgBox Disc_Sum

End Sub

| |