MS Project v stavebníctve

Finančný plán v MS Project s využitím VBA
(Visual Basic for Applications)

Častou prácou stavebných firiem v rámci prípravy je vypracovanie časového a finančného plánu výstavby. Tie nám poskytujú prehľad nasadenia procesov a zdrojov v čase. Pre rýchle spracovanie plánov využívame rôzne softvéry.

Ms project je častým nástrojom na tvorbu plánovania výstavby, preto sa budem zaoberať finančným plánom výstavby spracovaný v danom programe. Prácu v ms projecte si zjednoduším vopred vytvorenej tabuľke a makier, ktoré nám urobia jednoduché prepočty a prepoja stĺpce.
Samotný program neumožňuje prepojenie niektorých stĺpcov, ktoré riešim v editore jazyka Visual Basic.

Súbor si nastavíme na Zobrazenie- Harmonogram, v ktorom budeme pracovať (Obr1).

Vyplníme stĺpce Názov procesu, M.J., Množstvo, Nh/J, Počet Pracovníkov. Ak si chceme urobiť finančný plán, vložíme jednotkovú cenu procesu.

Pri využití externej databázy pre Normohodiny , nastavíme cestu a potvrdíme stlačením OK (Obr.2).

V dolnej ľavej roletke si vyberiem skupinu.
Po nastavení skupiny sa mi zobrazia Nh jednotlivých procesov (uvidím databázu Nh). Označím Názov procesu v tabuľke Harmonogram a stlačením PRIRAD Nh priradím hodnotu Nh, v Harmonograme môžem priradiť Nh k viac úlohám a to označením klik+ Shift, alebo klik+Ctrl.(Obr.3)

Po vložení základných údajov , stlačíme Prepocet , ktorý vypočíta dobu trvania . (Obr.4)

Zostáva iba vytvorenie väzieb medzi úlohami. (Obr. 5,6,7). Označíme si úlohy ( klik+Shift, alebo klik+Ctrl) a stlačíme Vytvořit vazbu mezi úkoly . Podobným spôsobom odstránime väzbu, s tým rozdielom, že stlačíme Odstranit vazbu mezi úkoly. Prodleva – opozdenie, alebo urýchlenie nadväzujúcej úlohy. Prodlevu možme zadať mínusovú, alebo plusovú hodnotu a to v %, d, ud atď . (uplynulá doba predstavuje reálný časový interval bez ohľadu na pracovnú dobu ( započítva aj nepracovné dni) – napríklad „ud“ je uplynulý den)

Vyriešený finančný plán môžeme sledovať v zobrazení Používaní úkolů .(obr.7)

Príklad: Harmonogram stavby

Zdrojový kód makier:

Option Explicit

Sub Prac()

Dim a, b, c, d, e, f, o As Long

Dim tskT As Task

'Premiestni zo stlpca cilo6 do zdrojov pracovnici

For a = 1 To ActiveProject.Resources.Count

If ActiveProject.Resources(a).Name = "Pracovnici" Then

b = a

Exit For

End If

Next a

If b = Empty Then

MsgBox "zdroj Pracovnici nie je v zozname"

Exit Sub

End If

'priradenie zdroja zo stlpca

For Each tskT In ActiveProject.Tasks

o = tskT.Number6

d = Empty

'cyklus porvnova ci sa nachadza Pracovnici

For c = 1 To tskT.Assignments.Count

If tskT.Assignments(c).ResourceName = ActiveProject.Resources(b).Name Then

d = c

'Ak je o hodnota vymaze zdroj , ak nie priradi

If o = 0 Then

tskT.Assignments(d).Delete

Else:

tskT.Assignments(d).Units = o

End If

'MsgBox "Podmienka splnena, c = " & c & " , b=" & b & ", ak zdroj =" & tskT.Assignments(c).ResourceName & ", tsk zdroj =" & ActiveProject.Resources(b).Name & ", Task ID= " & tskT.ID

Exit For

End If

Next c

'Ak proces dany zdroj v stlpci , musime ho vlozit

If d = Empty Then

tskT.Assignments.Add ResourceID:=b

For e = 1 To tskT.Assignments.Count

If tskT.Assignments(e).ResourceName = ActiveProject.Resources(b).Name Then

f = e

If o = 0 Then

tskT.Assignments(f).Delete

Else:

tskT.Assignments(f).Units = o

End If

Next e

End If

Next tskT

End Sub

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

Sub Trvanie()

Dim m As Long

Dim i As Long

Dim tskT As Task

'a = DurationFormat(tskTask.Duration, dayDurationElapsedUnits)

For Each tskT In ActiveProject.Tasks

m = tskT.Number8

tskT.Duration = m & "d"

Next tskT

End Sub

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

Sub Prepocet()

Call Prepocet1

Call Prepocet2

Call Trvanie

Call Prac

End Sub

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

Option Explicit

Sub Auto_Open()

Call CreateMenu

End Sub

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

Sub CreateMenu()

'vytvorenie ovladacie menu pre program

Dim HelpMenu As CommandBarControl

Dim NewMenu As CommandBarPopup

Dim MenuItem As CommandBarControl

Dim Submenuitem As CommandBarButton

'zmaze ponuku ked uz existuje

Call DeleteMenu

' najde Help Menu

Set HelpMenu = CommandBars(1).FindControl(ID:=30010)

If HelpMenu Is Nothing Then

' pridat menu na koniec

Set NewMenu = CommandBars(1).Controls.Add _

(Type:=msoControlPopup, _

temporary:=True)

Else

' pridat menu pred Help

Set NewMenu = CommandBars(1).Controls.Add _

(Type:=msoControlPopup, _

Before:=HelpMenu.Index, _

temporary:=True)

End If

' Pridat ponuku

NewMenu.Caption = "PRIVAT MAKRA"

'prepocet celkom

Set MenuItem = NewMenu.Controls.Add _

(Type:=msoControlButton)

With MenuItem

.Caption = "Prepocet"

.OnAction = "Prepocet"

End With

'prepocet Sum Nh,Sum Cena

Set MenuItem = NewMenu.Controls.Add _

(Type:=msoControlButton)

With MenuItem

.Caption = "Vypocet Sum Nh, Sum Cena"

.OnAction = "Prepocet1"

End With

'prepocet D.T.P./Smeny, Napatie

Set MenuItem = NewMenu.Controls.Add _

(Type:=msoControlButton)

With MenuItem

.Caption = "Vypocet D.T.P./Smeny, Napatie"

.OnAction = "Prepocet2"

End With

End Sub

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

Sub DeleteMenu()

On Error Resume Next

CommandBars(1).Controls("PRIVAT MAKRA").Delete

End Sub

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

Option Explicit

Sub Prepocet1()

Dim i As Long

Dim tskT As Task

'Vypocet SUM h, SUM cema

For Each tskT In ActiveProject.Tasks

tskT.Number3 = tskT.Number1 * tskT.Number2

tskT.Number5 = tskT.Number1 * tskT.Number4 'Nemusi byt, lebo pouzivam stlpec naklady

tskT.Cost = tskT.Number1 * tskT.Number4 'Pocita v stlpci naklady

Next tskT

End Sub

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

Sub Prepocet2()

Dim i As Long

Dim tskT As Task

'Podmienka riesenia

For Each tskT In ActiveProject.Tasks

If tskT.Number6 <= 0 Then

MsgBox "Nespravne zadanie hodnoty pracovnikov.Vypocet nenastane."

Exit Sub

End If

Next tskT

'Vypocet D.T.P/h

For Each tskT In ActiveProject.Tasks

If tskT.Number6 > 0 Then

If (tskT.Number3 / tskT.Number6) - Fix(tskT.Number3 / tskT.Number6) < 0.5 Then

tskT.Number7 = Fix(tskT.Number3 / tskT.Number6)

Else:

tskT.Number7 = Fix(tskT.Number3 / tskT.Number6) + 1

End If

Else:

tskT.Number7 = 0

End If

Next tskT

'Vypocet D.T.P./Smeny

For Each tskT In ActiveProject.Tasks

If (tskT.Number7 / ActiveProject.HoursPerDay) < 1 Then

tskT.Number8 = 1

Else:

If (tskT.Number3 / tskT.Number6 / ActiveProject.HoursPerDay) - Fix(tskT.Number3 / tskT.Number6 / ActiveProject.HoursPerDay) < 0.5 Then

tskT.Number8 = Fix(tskT.Number3 / tskT.Number6 / ActiveProject.HoursPerDay)

Else:

tskT.Number8 = Fix(tskT.Number3 / tskT.Number6 / ActiveProject.HoursPerDay) + 1

End If

Next tskT

'Vypocet Napatia

For Each tskT In ActiveProject.Tasks

tskT.Number10 = tskT.Number3 / tskT.Number6 / tskT.Number8 / ActiveProject.HoursPerDay * 100

Next tskT

End Sub

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

Option Explicit

Sub Prepocetcezzdroje()

Dim a, b, c, d, m, i As Long

Dim tskT As Task

'Prepocet zdrojov na zaklade Nh, prepocet mnozstva zdrojov na zaklade ich noriem spotreby

'Najde ID Praconici

For a = 1 To ActiveProject.Resources.Count

If ActiveProject.Resources(a).Name = "Pracovnici" Then

b = a

Exit For

End If

Next a

If b = Empty Then

MsgBox "zdroj Pracovnici nie je v zozname"

Exit Sub

End If

'Vypocet doby trvania

For Each tskT In ActiveProject.Tasks

If (tskT.Number1 * tskT.Number2 / tskT.Assignments(b).Units / ActiveProject.HoursPerDay) < 1 Then

m = 1

Else:

If (tskT.Number1 * tskT.Number2 / tskT.Assignments(b).Units / ActiveProject.HoursPerDay) - _

Fix(tskT.Number1 * tskT.Number2 / tskT.Assignments(b).Units / ActiveProject.HoursPerDay) < 0.5 Then

m = Fix(tskT.Number1 * tskT.Number2 / tskT.Assignments(b).Units / ActiveProject.HoursPerDay)

Else:

m = Fix(tskT.Number1 * tskT.Number2 / tskT.Assignments(b).Units / ActiveProject.HoursPerDay) + 1

End If

'Priradnie vypoctu do pola trvanie

tskT.Duration = m & "d"

' MsgBox "trvanie = " & m

For c = 2 To tskT.Assignments.Count

'Posudenie zdroja pri vypocte

If tskT.Assignments(c).ResourceType = pjResourceTypeMaterial Then

'Ak je mater.zdroj plati

tskT.Assignments(c).Units = tskT.Number1 * tskT.Assignments(c).Number2

Else:

'Ak je prac.zdroj plati

tskT.Assignments(c).Units = tskT.Number1 * tskT.Assignments(c).Number2 / m

End If

Next c

Next tskT

End Sub

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

Sub Normaspotreby()

'Priradenie pocet jednodtiek zo zdrojov do cisla2 (norma spotreby)

Dim c As Long

Dim tskT As Task

For Each tskT In ActiveProject.Tasks

For c = 1 To tskT.Assignments.Count

tskT.Assignments(c).Number2 = tskT.Assignments(c).Units

Next c

Next tskT

End Sub

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

Option Explicit

Public Const APPNAME As String = "Normohodiny"

Sub prehnormy()

Dim ResultStr As String

Dim filename As String

Dim FileNum As Integer

Dim Counter As Double

Dim c As String

Dim v, j, w, x, y, i As Long

Dim Label4 As Object

On Error Resume Next

'Odkaz na cestu k suboru k databaze

filename = InputBox("Vlozte cestu k nazvu csv suboru - databaza Normohodiny")

'filename = "D:\Nh22.csv"

Normohodiny.Label4 = filename

'ak je prazne tak opusti

If filename = "" Then End

'ziska cislo suboru

FileNum = FreeFile()

'Otvori Text File pre Input

Open filename For Input As #FileNum

If Err <> 0 Then

MsgBox "Nenasiel sa subor: " & filename, vbCritical, "ERROR"

Exit Sub

End If

Application.ScreenUpdating = False

w = 0

'Hlada pocet riadkov v subore

Do While Seek(FileNum) <= LOF(FileNum)

Line Input #FileNum, ResultStr

w = w + 1

Loop

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

FileNum = FreeFile()

Open filename For Input As #FileNum

Application.ScreenUpdating = False

ReDim n(1 To w, 1 To 3) As String

Counter = 1

'Plati podmienka pokial sa nenaplni bajtmi

Do While Seek(FileNum) <= LOF(FileNum)

'retazec v riadku

Line Input #FileNum, ResultStr

'MsgBox "" & InStr(ResultStr, ";")

'rozbije retazec tam kde je ;

Dim splitValues As Variant

splitValues = Split(ResultStr, ";")

n(Counter, 1) = Replace(splitValues(0), Chr(34), "")

n(Counter, 2) = Replace(splitValues(1), Chr(34), "")

n(Counter, 3) = Replace(splitValues(2), Chr(34), "")

Counter = Counter + 1

Loop

'Zavrie subor

'Naplnenie Comboxu udajmi ak 2 a 3stlpec je prazdny

For j = 1 To Counter - 1

If n(j, 2) = "" And n(j, 3) = "" Then

Normohodiny.ComboBox1.AddItem n(j, 1)

End If

Next j

'Zobrazi Form Normohodiny

Normohodiny.Show vbModeless

Application.ScreenUpdating = True

End Sub

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

Option Explicit

Private Sub ComboBox1_Change()

Dim ResultStr As String

Dim filename As String

Dim FileNum As Integer

Dim Counter As Double

Dim c As String

Dim v, j, w, x, y, i, o, u, t, a As Long

Dim Label4 As Object

On Error Resume Next

'Odkaz na cestu k suboru k databaze

'filename = InputBox("Vlozte cestu k nazvu csv suboru - databaza Normohodiny")

filename = Normohodiny.Label4

'ak je prazne tak opusti

If filename = "" Then End

'Get Next Available File Handle Number

FileNum = FreeFile()

'Otvori Text File pre Input

Open filename For Input As #FileNum

If Err <> 0 Then

MsgBox "Nenasiel sa subor: " & filename, vbCritical, "ERROR"

Exit Sub

End If

Application.ScreenUpdating = False

w = 0

'Hlada pocet riadkov v subore

Do While Seek(FileNum) <= LOF(FileNum)

Line Input #FileNum, ResultStr

w = w + 1

Loop

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

FileNum = FreeFile()

Open filename For Input As #FileNum

Application.ScreenUpdating = False

ReDim n(1 To w, 1 To 3) As String

Counter = 1

Do While Seek(FileNum) <= LOF(FileNum)

Line Input #FileNum, ResultStr

Dim splitValues As Variant

splitValues = Split(ResultStr, ";")

n(Counter, 1) = Replace(splitValues(0), Chr(34), "")

n(Counter, 2) = Replace(splitValues(1), Chr(34), "")

n(Counter, 3) = Replace(splitValues(2), Chr(34), "")

Counter = Counter + 1

Loop

'Zistenie pociatku skupiny pod, ktorou su podpolozky

For j = 1 To Counter - 1

If n(j, 1) = Normohodiny.ComboBox1.Value Then

x = j

Exit For

End If

Next j

For j = x + 1 To Counter - 1

If n(j, 2) = "" And n(j, 3) = "" Then

y = j

Exit For

End If

Next j

If y = Empty Then

y = Counter

End If

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

'Vlozenie do list boxu

ReDim M((u + 1) To (y - x), 1 To 3)

For o = 1 To 3

u = 0

For i = x + 1 To y - 1

u = u + 1

M(u, o) = n(i, o)

Next i

Next o

'Hlada najdlhsi retazec v poli pre dynamicky stlpec v listboxe

t = Len(n(i - 1, 1))

For i = x + 1 To y - 1

If Len(n(i, 1)) > t Then

t = Len(n(i, 1))

End If

Next i

With Normohodiny.ListBox1

.ColumnWidths = (t * 5) & " ;50;50"

.List = M

.ListIndex = -1

End With

Application.ScreenUpdating = True

End Sub

Private Sub CommandButton1_Click()

'Priradenie oznacenej polozky v listboxe k Tasku

Dim r As Integer

Dim tskT As Task

'pracuje v oznacenych bunkach

For Each tskT In ActiveSelection.Tasks

For r = 0 To ListBox1.ListCount - 1

If Normohodiny.ListBox1.Selected(r) Then

tskT.Number2 = ListBox1.List(r, 2)

End If

Next r

Next tskT

End Sub

Private Sub ListBox1_Click()

End Sub

Sub GD()

'Nacita vlastnosti z registra

Dim ctl As Control

Dim CtrlType As String

For Each ctl In Me.Controls

CtrlType = TypeName(ctl)

If CtrlType = "Label" Then

ctl.Value = VBA.GetSetting _

(APPNAME, "Defaults", ctl.Name, ctl.Value)

End If

Next ctl

End Sub

Sub SD()

'Zapise hodnoty do registra

Dim ctl As Control

Dim CtrlType As String

For Each ctl In Me.Controls

CtrlType = TypeName(ctl)

If CtrlType = "Label" Then

SaveSetting APPNAME, "Defaults", ctl.Name, ctl.Value

End If

Next ctl

End Sub

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

Sub prehzdrojov()

Dim ResultStr As String

Dim filename As String

Dim FileNum As Integer

Dim Counter As Double

Dim c As String

ReDim p(1 To 100) As String

ReDim z(1 To 100) As String

ReDim M(1 To 100) As String

Dim v As Long

ReDim n(1 To 100, 1 To 3) As String

On Error Resume Next

'Odkaz na cestu k suboru k databaze

filename = InputBox("Vlozte cestu k nazvu csv suboru databaza zdrojov")

'filename = "D:\cfplan22.csv"

'ak je prazne tak opusti

If filename = "" Then End

'ziska cislo suboru

FileNum = FreeFile()

'Otvori Text File pre Input

Open filename For Input As #FileNum

'Ak sa nenajde subor vypise chybu

If Err <> 0 Then

MsgBox "Nenasiel sa subor: " & filename, vbCritical, "ERROR"

Exit Sub

End If

Application.ScreenUpdating = False

Counter = 1

'Hlada pocet riadkov v subore

Do While Seek(FileNum) <= LOF(FileNum)

Line Input #FileNum, ResultStr

''rozbije retazec tam kde je ;

Dim splitValues As Variant

splitValues = Split(ResultStr, ";")

n(Counter, 1) = Replace(splitValues(0), Chr(34), "")

n(Counter, 2) = Replace(splitValues(1), Chr(34), "")

n(Counter, 3) = Replace(splitValues(2), Chr(34), "")

Counter = Counter + 1

Loop

'Zatvori subor

Application.ScreenUpdating = True

With zdroje.ListBox1

.ColumnWidths = "200;90;50"

.List = n

.ListIndex = -1

End With

For j = 1 To Counter - 1

zdroje.ComboBox1.AddItem n(j, 2)

Next j

'Zobrazi Form zdroje

zdroje.Show vbModeless

Application.ScreenUpdating = True

End Sub

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

Sub Import()

Dim ResultStr As String

Dim filename As String

Dim FileNum As Integer

Dim Counter As Double

Dim l As String

Dim i As Long

Dim tskT As Task

Dim r As Resource

Dim a As Assignment

Dim b, h As Boolean

Dim c, d, e, f, q As Long

ReDim p(1 To 100) As String

ReDim z(1 To 100) As String

ReDim M(1 To 100) As String

On Error Resume Next

'Odkaz na cestu k suboru k databaze

filename = InputBox("Vlozte cestu k nazvu csv suboru databaza zdrojov")

'filename = "D:\cfplan22.csv"

'ak je prazne tak opusti

If filename = "" Then End

'ziska cislo suboru

FileNum = FreeFile()

'Open Text File For Input

Open filename For Input As #FileNum

'Ak sa nenajde subor vypise chybu

If Err <> 0 Then

MsgBox "Nenasiel sa subor: " & filename, vbCritical, "ERROR"

Exit Sub

End If

Application.ScreenUpdating = False

Counter = 1

'Hlada pocet riadkov v subore

Do While Seek(FileNum) <= LOF(FileNum)

'retazec v riadku

Line Input #FileNum, ResultStr

Dim splitValues As Variant

'rozbije retazec tam kde je ;

splitValues = Split(ResultStr, ";")

p(Counter) = Replace(splitValues(0), Chr(34), "")

z(Counter) = Replace(splitValues(1), Chr(34), "")

M(Counter) = Replace(splitValues(2), Chr(34), "")

Counter = Counter + 1

Loop

'Zavrie subor

Application.ScreenUpdating = True

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

For i = 1 To Counter - 1

b = Empty

'Hlada zdroj v zozname

For Each r In ActiveProject.Resources

If r.Name = z(i) Then

b = True

' MsgBox "zdroj najdeny : " & z(i)

Exit For

End If

Next r

If b = False Then

'MsgBox "empty : " & b

ActiveProject.Resources.Add (z(i))

'MsgBox "zdroj je zapisany : " & z(i)

End If

Next i

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

'Priradenie Assigmments

For Each tskT In ActiveProject.Tasks

For i = 1 To Counter - 1

If tskT.Name = p(i) Then

'MsgBox "uloha ms prosject: " & tskT.Name & " - proces data : " & p(i)

For Each a In tskT.Assignments

h = Empty

If a.ResourceName = z(i) Then

h = True

' MsgBox "zdroj najdeny : " & z(i) & " b : " & h

Exit For

End If

Next a

'Podmienka ak je assigments prazdny

If a Is Nothing Then

h = Empty

End If

For Each r In ActiveProject.Resources

If r.Name = z(i) Then

' MsgBox "zdroj najdeny : " & z(i)

q = r.ID

'MsgBox "ID najdeny : " & q & " nazov : " & r.Name

Exit For

End If

Next r

If h = Empty Then

' MsgBox "empty nenajdeny: " & h & ", zdroj : " & z(i)

tskT.Assignments.Add ResourceID:=q

End If

Next i

Next tskT

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

'Priradnie jednotiek

For Each tskT In ActiveProject.Tasks

For i = 1 To Counter - 1

If tskT.Name = p(i) Then

'MsgBox "uloha ms prosject: " & tskT.Name & " - proces data : " & p(i)

For Each a In tskT.Assignments

h = Empty

If a.ResourceName = z(i) Then

h = True

a.Number2 = M(i)

' MsgBox "zdroj najdeny : " & z(i) & " b : " & h

Exit For

End If

'MsgBox "zdroj nenajdeny : " & z(i) & " b : " & b

Next a

End If

Next i

Next tskT

Application.ScreenUpdating = True

End Sub

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

Private Sub CommandButton1_Click()

Call Import

End Sub

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

Sub Importexcel()

'Import udajov z excelu

Dim objExcel As New Excel.Application

Dim wb As Excel.Workbook

Dim tsk As Task

Set wb = objExcel.Workbooks.Open("D:\plan.xls")

For Each tskT In ActiveSelection.Tasks

tskT.Name = wb.Sheets("1").Cells(1, 1)

Next tskT

End Sub

MS Project v stavebníctve

Bestpoint - for gentlemen

Krejčovství Knoflíček

El. polohovací postele