監造日報表系列-遇到變更設計怎麼辦?

監造日報表系列中的隱藏模組-變更設計

變更設計最麻煩的的一點就是要處理變更加減帳的問題，主體+雜項的變更前後比例還會影響到編製預算書時所用到的比例項目更正，因此既然監造日報表裡面的工作表("Budget")已經有紀錄著PCCES匯入的預算書資料，那麼透過這個工作表的再開發應該可以更快的得到「變更設計總表」、「變更設計明細表」，因此而撰寫這個專案，每次算加減帳都會被主辦退，這次應該不會被退了，電腦自己算給你!


變更設計狀況
圖一、變更設計狀況(1=新增項目新增單價，2=數量變更，3=單價變更)



圖二、變更設計總表

圖三、變更設計明細表

相關範例程式碼如下:

'also need "clsBudgetItems" ClassModule

Private shtBudget As Worksheet
Private shtCBudget As Worksheet
Private obj As New clsBudgetItems

Private collAddress As New Collection
Private ItemCountArray As Variant
Public IsFixItemCount As Boolean
Private mode As String
Private ratio As Double

Private Sub Class_Initialize()

Set shtBudget = Sheets("Budget")
Set shtCBudget = Sheets("CBudget")

'取得預算書的資料
'get budget data from sheets("Budget")

obj.getData
obj.sumEachSepPrice

a = obj.sumSpecificPrice(1, 2)
b = obj.sumSpecificCPrice(1, 2)

ratio = b / a 'get the ratio to check other item

End Sub

Sub getPrintPage()

'&P=當前頁數
'&N=總頁數
'2020.05.05 update

Dim sht As Worksheet

HP = ActiveSheet.HPageBreaks.count + 1 '縱向頁數
VP = ActiveSheet.VPageBreaks.count + 1 '橫向頁數
PG = HP * VP '總頁數

Set sht = Sheets("CBudget")

If PG > 1 Then

sht.PageSetup.RightHeader = "第 &P+1 頁,共 &N+1頁"

sht.Range("L3") = "第1頁,共" & PG + 1 & "頁"
sht.Range("L3").Font.ColorIndex = 2

Else

sht.PageSetup.RightHeader = ""
sht.Range("L3").Font.ColorIndex = 1

End If

End Sub

Sub getMode()

mode = InputBox("1.專案工程" & vbctrl & "2.自籌款", , "1")

If mode = "1" Then

    'ItemCountArray = Array("一", "二", "三", "四", "五a", "五b", "六", "七", "八", "貳", "參", "肆", "伍", "陸")
    ItemCountArray = Array("一", "二", "三", "四", "五a", "五b", "六", "七", "八", "九", "貳", "參", "肆", "伍", "陸")
    
ElseIf mode = "2" Then '自籌款沒有工程保險費

    ItemCountArray = Array("一", "二", "三", "四", "五a", "五b", "六", "七", "貳", "參", "肆", "伍", "陸")

End If

End Sub

Sub ClearAll2() '清理格式

With shtCBudget

Do Until .Cells(7, 2) = ""

    .Rows(7).Delete

Loop

End With

End Sub

Sub RetriveData() '從變更預算明細表上的資料名稱去回傳應該是正確的變更預算資料

With shtCBudget

    lr = .Cells(.Rows.count, 2).End(xlUp).row
    
    For r = 7 To lr

        myunit = .Cells(r, 3)
        
        '若為顯示總表的時候會出現錯誤(可以為顯示明細表時解除該bug)
        '因為累計項目的col=3不為""
        'EX:主體工程工作費、雜項工程工作費...etc
        '2020.05.05 update
        
        If myunit <> "" Then
        
            myitem = .Cells(r, 2)
        
            myindex = obj.collItemIndex(myitem)

            Call WriteData(myindex, r)
        
        End If
        
        
    Next

End With

End Sub

Sub ReadData() 'Main function

r = 7

With shtCBudget

    For Each mSepEach In obj.collSepEach
    
        IsSingle = CheckIsSingle(mSepEach) '檢查是否為單一項目
    
        i = 0 'Controll mSep
        count = 0
        
        Call AddTitle(r, mSepEach, IsSingle) '新增項次以及項目名稱
        
        For Each mSep In obj.collSep
        
            i = i + 1
            
            If mSep = mSepEach Then
                
                count = count + 1
                
                If IsSingle Then
                    Call WriteData_Single(i, r, count)
                Else
                    Call WriteData_Mix(i, r, count)
                End If
        
            End If
        
        Next
        
        Call AddSum(r, mSepEach, IsSingle)
    
    Next

End With

End Sub

Sub WriteData(ByVal i As Integer, ByVal r As Integer)

Item = obj.collItem(i)
unit = obj.collUnit(i)
Num = obj.collNum(i)
Num_ch = obj.collCNum(i)
money = obj.collPrice(i)
totalmoney = Num * money
totalmoney_ch = obj.collCNum(i) * obj.collCPrice(i)

With shtCBudget

.Cells(r, 2) = Item
.Cells(r, 3) = unit '.Cells(r, 3)
.Cells(r, 4) = Num '.Cells(r, 5)
.Cells(r, 5) = Num_ch '.Cells(r, 4)

Call getDiff(r, Num, Num_ch, "F", "G")

.Cells(r, "H") = money '.Cells(r, 6)
.Cells(r, "I") = totalmoney '.Cells(r, 8)
.Cells(r, "J") = totalmoney_ch '.Cells(r, 9)

Call getDiff(r, totalmoney, totalmoney_ch, "K", "L")

End With

End Sub

Sub WriteData_Single(ByVal i As Integer, ByRef r, ByVal count As Integer)

r = r - 1

Call WriteData(i, r)
Call FormulaRow(r, 3)

shtCBudget.Cells(r, "M") = "=getSumDiff(K" & r & ",L" & r & ")"

collAddress.Add r

r = r + 1

End Sub

Sub WriteData_Mix(ByVal i As Integer, ByRef r, ByVal count As Integer)

shtCBudget.Cells(r, 1) = count

Call WriteData(i, r)
Call FormulaRow(r, 2)

r = r + 1

End Sub

Sub FormulaRow(ByVal r As Integer, ByVal mode As Byte)

If IsFixItemCount = True Then Exit Sub

With shtCBudget.Range("A" & r & ":M" & r)
    
    .VerticalAlignment = xlCenter
    .Borders.LineStyle = 1
    .Font.Name = "標楷體"
    .Parent.Range("H" & r & ":J" & r).NumberFormatLocal = "#,##0"
    .Parent.Range("K" & r & ",L" & r).NumberFormatLocal = "#,##"
    
    If mode = 1 Then 'for Title
    
        .Font.Size = 14
        .RowHeight = 30
    ElseIf mode = 2 Then 'for Content
    
        .Font.Size = 12
        .RowHeight = 25
        
        If Len(.Parent.Range("B" & r)) > 10 Then
        
            .Parent.Range("B" & r).WrapText = True
            .EntireRow.AutoFit
            If .RowHeight < 25 Then .RowHeight = 25
    
        End If
    
    ElseIf mode = 3 Then 'for Content(only one)
    
        .Font.Size = 14
        .RowHeight = 30
    
    End If

End With

End Sub

Sub AddSum(ByRef r, ByVal SepName As String, ByVal IsSingle As Boolean)

Call FormulaRow(r, 1)

If IsSingle Then Exit Sub

With shtCBudget

    collAddress.Add r

    .Cells(r, 2) = SepName & "計"

    r = r + 1
    
End With

End Sub

Sub AddTitle(ByRef r, ByVal SepName As String, ByVal IsSingle As Boolean)

On Error GoTo ERRORHANDLE

Call FormulaRow(r, 1)

count = obj.collSepEachIndex(SepName)

shtCBudget.Cells(r, 1) = "(" & ItemCountArray(count - 1) & ")"
shtCBudget.Cells(r, 2) = SepName

'if count=

r = r + 1

Exit Sub

ERRORHANDLE:
End

End Sub

Sub ChangeCellColor() '改變變更後的文字顏色

With shtCBudget

    lr = .Cells(.Rows.count, 2).End(xlUp).row
    
    For r = 7 To lr
    
        If .Cells(r, "E") <> .Cells(r, "D") Then .Cells(r, "E").Font.ColorIndex = 3
        If .Cells(r, "I") <> .Cells(r, "J") Then .Cells(r, "J").Font.ColorIndex = 3
        
        .Range("F" & r & ":G" & r & ",K" & r & ":M" & r).Font.ColorIndex = 3
        
    Next
    
    .PageSetup.PrintArea = "A1:M" & lr '2020.05.05 update

End With

End Sub

Sub useSumFormula()

With shtCBudget

lr = .Cells(.Rows.count, 2).End(xlUp).row

For r = 7 To lr

    If .Cells(r, 1) = "1" Then sr = r
    If .Cells(r, 1) = "" Then
        er = r
        
        .Cells(r, "I") = "=SUM(I" & sr & ":I" & er - 1 & ")"
        .Cells(r, "J") = "=SUM(J" & sr & ":J" & er - 1 & ")"
        .Cells(r, "K") = "=SUM(K" & sr & ":K" & er - 1 & ")"
        .Cells(r, "L") = "=SUM(L" & sr & ":L" & er - 1 & ")"
        
        Sum = .Cells(r, "K") '正項目相加
        CSum = .Cells(r, "L") '負項目相加
        .Cells(r, "M") = "=getSumDiff(K" & r & ",L" & r & ")" ' getSumDiff(Sum, CSum)"

    End If
    
Next

End With

End Sub

Sub DealSpecificSum()

With shtCBudget

    lr = .Cells(.Rows.count, 2).End(xlUp).row

    For r = lr To 3 Step -1
        
        Select Case .Cells(r, 1)
    
        Case "(一)"
            .Cells(r, 1).EntireRow.Insert xlShiftUp, xlFormatFromRightOrBelow
            .Cells(r, 1) = "(壹)"
            .Cells(r, 2) = "發包工作費"
    
        'Case "(三)"
        Case "(四)"
        
            .Cells(r, 1).EntireRow.Insert xlShiftUp
            '.Cells(r, 2) = "(一)~(二)小計"
            'Call loopSumFormula(r - 1, 2)
            .Cells(r, 2) = "(一)~(三)小計"
            Call loopSumFormula(r - 1, 3)
            .Cells(r, "M") = "=getSumDiff(K" & r & ",L" & r & ")"
            '.Cells(r, "M") = getSumDiff(.Cells(r, "K"), .Cells(r, "L"))

        Case "(六)"
        
            .Cells(r, 1).EntireRow.Insert xlShiftUp
            .Cells(r, 2) = "(五a)+(五b)小計"
            Call loopSumFormula(r - 1, 6, 5)
            .Cells(r, "M") = "=getSumDiff(K" & r & ",L" & r & ")"
        
        'Case "(七)"
         Case "(八)"
            If mode = "2" Then
            
                .Cells(r + 1, 1).EntireRow.Insert xlShiftUp
                .Cells(r + 1, 2) = "發包工作費總額"
                Call loopSumFormula(r, 7 + 1 + 1)
                .Cells(r + 1, "M") = "=getSumDiff(K" & r + 1 & ",L" & r + 1 & ")"
    
                '.Cells(r + 1, 1).EntireRow.Insert xlShiftUp
                '.Cells(r + 1, 2) = "(三)~(七)小計"
                'Call loopSumFormula(r, 7 + 1, 3)
                '.Cells(r + 1, "M") = "=getSumDiff(K" & r + 1 & ",L" & r + 1 & ")"

            End If

        'Case "(八)"
        Case "(九)"
        
            If mode = "1" Then
            
                .Cells(r + 1, 1).EntireRow.Insert xlShiftUp
                .Cells(r + 1, 2) = "發包工作費總額"
                Call loopSumFormula(r, 8 + 2)
                .Cells(r + 1, "M") = "=getSumDiff(K" & r + 1 & ",L" & r + 1 & ")"
          
                '.Cells(r + 1, 1).EntireRow.Insert xlShiftUp
                '.Cells(r + 1, 2) = "(三)~(八)小計"
                'Call loopSumFormula(r, 8 + 1, 3)
                '.Cells(r + 1, "M") = "=getSumDiff(K" & r + 1 & ",L" & r + 1 & ")"

            End If
        
        End Select
            
        If r = lr Then
        
            .Cells(r + 1, 1).EntireRow.Insert xlShiftUp
            .Cells(r + 1, 2) = "總工程費"
            Call loopSumFormula(r, collAddress.count)
            .Cells(r + 1, "M") = "=getSumDiff(K" & r + 1 & ",L" & r + 1 & ")"
            '.Cells(r + 1, "M") = getSumDiff(.Cells(r + 1, "K"), .Cells(r + 1, "L"))
            
        End If
    
    Next

End With

End Sub

Private Function CheckIsSingle(ByVal mSep As String)

With shtBudget
    
    Set brng = .Columns(1).Find(what:=mSep)
    
    Set arng = .Columns(1).FindNext(brng)
    
    If arng.Address = brng.Address Then
        CheckIsSingle = True
    Else
        CheckIsSingle = False
    End If

End With

End Function

Private Function getDiff(ByVal r As Integer, ByVal before As Double, ByVal after As Double, _
                        ByVal addcol As String, ByVal minuscol As String)

With shtCBudget

    If before > after Then
        .Cells(r, minuscol) = before - after
    ElseIf before < after Then
        .Cells(r, addcol) = after - before
    End If

End With

End Function

Private Sub loopSumFormula(ByVal r As Integer, ByVal count As Integer, Optional ByVal scount As Integer = 1)

arr = Array("I", "J", "K", "L")

For i = 0 To UBound(arr)

    shtCBudget.Cells(r + 1, arr(i)) = getSumFormula(count, arr(i), scount)

Next

End Sub

Private Function getSumFormula(ByVal count As Integer, ByVal col As String, Optional scount As Integer = 1)

For i = scount To count

    f = f & "+" & col & collAddress(i)

    getSumFormula = "=SUM(" & Mid(f, 2) & ")"

Next

End Function

Sub getAllReport(ByVal IsHidden As Boolean)

arr = Array("I", "J", "K", "L", "M")

With shtCBudget

    lr = .Cells(.Rows.count, 2).End(xlUp).row
    
    For r = 7 To lr
    
        If .Cells(r, 1) Like "(*" Then
          
          targetrow = getSumRow(r, .Cells(r, 2), IsSingle)
          
          If IsSingle = False Then
          
            For i = LBound(arr) To UBound(arr)
            
              If IsHidden = True Then
                .Cells(r, arr(i)) = "=" & arr(i) & targetrow
                .Cells(r, "C") = "式"
                .Cells(r, "D") = 1
                .Cells(r, "E") = 1
              Else
                .Cells(r, arr(i)) = ""
                .Range("C" & r & ":E" & r) = ""
              End If
              
            Next
            
            .Cells(targetrow, 1).EntireRow.Hidden = IsHidden
          
          End If
          
        ElseIf .Cells(r, 1) = "" Then
        
        Else
        
                .Cells(r, 1).EntireRow.Hidden = IsHidden

        End If
    
    Next

If IsHidden = True Then

    For Each cmt In .Comments
        
        cmt.Delete

    Next cmt
    
    '當分頁強制分開時，可以將強制分開的格線打破，讓總表維持在一頁
    
    If .HPageBreaks.count <> 0 Then
        .HPageBreaks(1).DragOff xlDown, 1
    End If
    .PageSetup.PrintArea = "A1:M" & lr

End If

End With

End Sub

Sub CheckRatio()

tmp = InputBox("目前的檢查係數為" & ratio & vbctrl & "請輸入欲檢查的分類項目:", _
                , "三,四,五a,六,七")

chtmps = Split(tmp, ",")

With shtCBudget
    lr = .Cells(.Rows.count, 2).End(xlUp).row
    For r = 7 To lr
        
        If .Rows(r).Hidden = False Then
        
            For Each chtmp In chtmps
                
                If .Cells(r, 1) = "(" & chtmp & ")" Then
                
                    ratioMoney = .Cells(r, "I") * ratio
                    
                    Debug.Print .Cells(r, 1) & ":" & ratioMoney
                    
                    If .Cells(r, "J") >= ratioMoney Then MsgBox .Cells(r, 1) & .Cells(r, 2) & "編制過高!!", vbCritical
                    
                    On Error Resume Next
                    .Cells(r, "J").Comment.Delete
                    On Error GoTo 0

                    .Range("J" & r).AddComment
                    .Range("J" & r).Comment.Visible = False
                    .Range("J" & r).Comment.Text Text:=CStr(Round(ratioMoney, 3))
                    
                    Exit For
                    
                End If
                
            Next
        
        End If
        
    Next

    For Each cmt In .Comments
    
      With cmt.Shape.TextFrame.Characters.Font
        .Name = "Times New Roman"
        .Size = 14
      End With
      
    Next cmt
    
End With

End Sub

Function getSumRow(ByVal r As Integer, ByVal Sep As String, ByRef IsSingle)

With shtCBudget

    Set rng = .Columns.Find(what:=Sep & "計")

    If rng Is Nothing Then
        getSumRow = r
        IsSingle = True
    Else
        getSumRow = rng.row
        IsSingle = False
    End If

End With

End Function

留言

張貼留言

Popular Posts

Excel VBA @ 監造日報表、查驗表 -2

圖片
***如需施工日誌請參考 這裡 *** 新版本20111214 已經更新!! 前言： 在經歷多次改版，發現使用的步驟還是有點多餘而且不夠自動化，此次將用物件類別模組的方式來修改Ver1.0留下尚可使用的程式碼，打造嶄新的監造日報表Ver2.0，輸出模式改為PDF，請搭配 PDFBinder 進行使用會比較方便。 準備文件： 以PCCES所編制並匯出成Excel之預算書報表 工程預算書中的數量計算表、土方計算表 監造日報表VBA使用手冊( 下載點我 ) 請開啟巨集並於login頁註冊後登入即可使用 圖一、Login頁面中點選註冊後跳至Google表單，填寫後即可以登入使用 參考文章： 專文1-PCCES處理到預算書 專文2-基本資料填寫 專文3-整個報表的靈魂 專文4-預定進度湊不到100%的解法  (20221204更新) 使用過程簡介： 1.  於工作表("Main")中填寫有關 工程名稱、 試體名稱(P.S.1) 、施工渠道名稱、進度資料等。 2.  於工作表("Budget")中點選"取得預算書"，修正為圖二所展示的內容。 圖二、取得預算書結果，如果需要整理準則，請參考設定準則的註解進行設定，並點選"重整準則" 3.  整理完成後並且更改為契約單價後，點選"匯出至報表"，資料會傳送至工作表("Main")，如下圖三所展示。 圖三、工作表("Main")中的報表資料，A~E欄為放置Step1 中的基本資料。 4.  於工作表("Records")中點選"填寫表單"，如圖四，即可進行一系列的資料紀錄，      為供應Diary及Check的基底資料。 圖四、施作項目來源是Main中的試體名稱與報表資料，如填寫資料有需要進行查驗，可以直接勾選(可複選) 5. 填寫完之後點選"傳送至Check"，再至工作表("Check")中點選"列印查驗"，     成果將輸出到該目錄下的查驗表Output中，名稱為查驗表代碼-頁碼.PDF
Read more »

ExcelVBA@施工照片整理的應用範例

圖片
前言： 施工照片或者查驗照片對於許多工程人員來說，是個繁瑣的麻煩事。畢竟照片只是一張圖片，需要用人眼去判讀才有辦法了解內容是什麼，因為通常會有一張白板與工地現場進行合照，然而當撰寫白板的人寫字醜到不行時，會使人瘋狂。因此在施工照片的整理上，只要能解決 照片的資訊標示 與 報表位置自動貼附並調整大小 ，想必會讓各位有此類需求的工程人員節省許多時間。 相片的收集來源有以下方式 從相機的SD卡或手機連接USB直接進行下載，其檔案名稱通常為IMG_XXXX 或 DCIM_XXXX 。 透過LINE社群中建立相簿，並將同類屬性的照片丟進同一個相簿中，爾後再透過LINE電腦版將整本相簿進行下載，其檔案名稱通常為 LINE_ALBUM_相簿名稱_XXXX 。 上述兩種方式為筆者曾經使用過的方法，於資料夾檢視情況下僅有縮圖及沒有資訊標示的檔案名稱，需要雙擊展開大圖後才有辦法判讀該相片的用途，雖然上面有一張小白板的合照，但還是需要點開之後才有辦法了解內容是什麼，而【點開】並做【資訊標示】， 本身就是一件很麻煩的事 。 解決方案： 筆者的作法是將照片先整理至一個資料夾的底下，並透過LINE相簿在進行批次下載時指定其子資料夾名稱。之後便透過我所撰寫的【施工照片瀏覽及更名】的VBA小程式進行照片的資訊標示與報表輸出，詳細操作流程如下 點擊【取得資料夾】按鈕，選取已整理好的根資料夾位置。 點擊【貼上結果】按鈕，選取是否要在工作表上顯示縮圖及大小。 移動至工作表(Result)，若於工作表(Main)中有設定顯示大圖，則進入工作表(Result)中便會根據滑鼠選取的欄位顯示相對應的大圖資訊，並留有資訊標示欄位供使用者輸入做修改。 圖一、施工照片大圖資訊 有關施工照片資訊標示均輸入完畢之後，移動至工作表(Main)點擊【更換檔名】按鈕，以VBA可判讀的資訊標示的格式進行檔案名稱儲存，未來若有相對應的格式，系統會自動判讀並做預先設定，不用再輸入一次。 點擊【列印報表】按鈕，將會依照排序方法(時間或者項目)，依序將照片自動貼上於報表中並轉換成XLS或PDF， 製作成PDF才有辦法將檔案發布給其他人使用 ，如為XLS則會在自身電腦中並帶有照片原始檔的狀況下才能看到圖片。 圖三、施工照片報表輸出PDF模式。 圖三、施工照片報表輸出XLS。 若有施工照片需要的朋友們 施工照片VBA買斷版連結 *0313更
Read more »

Excel VBA@ 監造日報表、查驗表

圖片
新版本請參考:  監造日報表Ver2.0 前言： 工程線流程：測量→設計→發包→監造→驗收→移交。 其中，監造有相當多的文件及注意事項，比如施作數量、成本監控、品質管制(查驗表)、重大期程(工程督導、說明會、變更(修正)設計、展延工期...等等)，在文件上的處理可說是相當的繁瑣。 光是品質管制的查驗表就分為： 開挖(放樣)工程查驗表 土方工程施工查驗表 鋼筋施工組立查驗表 模版施工組立查驗表 混凝土施工作業查驗表 模版及混凝土施工完成作業查驗表 職業安全衛生暨環境保護措施查驗表 在查驗表的表頭須註明工程名稱、工程位置、施作內容、施作日期...等， 已經在監造日報表中出現過 的部分，配合監造日報表的數量、單價、預定進度可以輕易的找到累積數量、累積成本、累積進度，去判斷是否有落後。 主要構想： 以往都是以複製的方式去拉出一連串的日報，只要連結錯誤，就是整批的更改連結，相當麻煩。因此寫了一個Side Project 用ExcelVBA去執行監造日報表的填寫過程，將工作表分為： 監造日報表     (輸出的樣版長相) 日報基本資料 (單價、數量、是否變更、基本工程綱要、試體、渠道數等重要資料) 數量及計算     (進度、天氣狀況、施作單價、施作數量) 施工日誌         (工程位置、施作內容、查驗項目、重大期程) 查驗總表         (與查驗有關的項目及查驗後內容都在此) 經基本資料填寫後，取得預算書(將PCCES的資料丟入，會依照主體工程、雜項工程、職業安全衛生、環境保護措施...等主要項目匯入到日報基本資料的工作表中，日後 僅需要進行填寫數量 ，就會將所有相關資料導入至數量及計算、施工日誌、查驗總表...等工作表，減少重複的資料一直出現，再透過主介面的"監造日報表"、"查驗表"，選擇列印模式即可批次列印。 圖一、程式主要介面 圖二、填寫數量介面 圖三、監造日報表樣版產出 圖四、某一查驗表產出
Read more »