Excel VBA @竣工文件

範例影片：

前言：

工程報竣工後會有一堆文件需要輸出給上級機關簽核，尤其是當下載下來後都是分散的話，每個輸出都要點擊一次列印、調整列印份數，可是會相當麻煩，因此寫了一個VBA來簡化這些問題。
圖一、上級機關需要的文件的一部分。
 使用方法：

  1. 必須先將所有要輸出的文件與"竣工派驗VBA.xlsm"放在同一個資料夾。
  2. 檢查該文件的工作表名稱及相對應的文件編號(需要在程式碼  Arrange 中更改)。
  3. 若有資料先清除資料。
  4. 詳細檢查各個文件的內容正確性。
  5. 列印。
圖二、Arrange中的一部分程式碼(arr與arr2數量需要相同，否則會出錯)
結論：

因應每家機關需要的文件不同，需要透過更改程式碼量身打造需要的文件名稱與編號，故提供的程式碼僅供參考使用。

程式碼：
Sub main()

Call GetFile

Call MoveData

Call Arrange

Call sortvba

Sheets(1).Select

End Sub

Sub GetFile()

Path = ThisWorkbook.Path '相對路徑

ChDir Path

f = Dir("")

Do Until f = ""

    If Not f Like "竣工派驗VBA*" Then
    
        Workbooks.Open f, False
    
    End If

    f = Dir()

Loop

End Sub

Sub MoveData()

For Each Workbook In Workbooks

    wbn = Workbook.Name
    
    Workbooks(wbn).Activate
    
    If Not wbn Like "竣工派驗VBA*" Then
    
        i = 0
    
        For Each Sheet In Sheets
        
            wpt = InStr(1, wbn, ".")
        
            If wpt <> 0 Then shn = Mid(wbn, 1, wpt - 1)
        
            pt = InStr(1, wbn, "_")
            
            If pt <> 0 Then shn = Mid(wbn, 1, pt - 1)
        
            If Sheets.Count = 1 And i = 0 Then
            
                Sheets(1).Name = shn
            
            Else
                
                i = i + 1
                Sheet.Name = shn & "-" & i
            
            End If
        
            Sheet.Move after:=Workbooks(1).Sheets(Sheets.Count)
        
        Next

    End If

Next

End Sub

Sub DeleteData()

For Each Sheet In Sheets

If Sheet.Index <> 1 Then

Application.DisplayAlerts = False

Sheet.Delete

Application.DisplayAlerts = True

End If

Next

End Sub

Sub Arrange()

Dim OrderArr(0 To 15, 1 To 2) As Variant

arr = Array("施工過程異動紀錄統計表", "施工品質評量表", "工程驗收單", "工程請款黏貼紙" _
            , "工程興辦成本明細表", "工程結算驗收證明書", "工程移管清冊-2", "工程移管清冊-1" _
            , "工程報廢單", "工程初驗、驗收、再驗紀錄表", "工程保固切結書", "竣工日期書面通知單")

arr2 = Array(3, 14, 8, 5, 13, 9, "16-2", "16-1", 12, 7, 15, 1)

For i = 0 To UBound(arr)

    OrderArr(i, 1) = arr(i)
    OrderArr(i, 2) = arr2(i)
    
Next

For Each Sheet In Sheets

    If Sheet.Index > 1 Then
    
        For i = 0 To UBound(arr)
        
            If Sheet.Name = OrderArr(i, 1) Then
            
                Sheet.Name = OrderArr(i, 2)
        
                Exit For
                
            End If
        Next
    
    End If

Next

End Sub

Sub printvba()

Dim FileName As String
Dim FIleCopies As Integer
Dim num As Integer

FinalType = InputBox("請問你的工程經費來源是?" & vbCrLf & "1.農委會補助" & vbCrLf & "2.自籌款", "竣工派驗VBA")

msg = MsgBox("請問要預覽列印後再印嗎?(Y/N)", vbYesNo)

If FinalType = 1 Then

    PrintCol = 9

ElseIf FinalType = 2 Then

    PrintCol = 12

End If

For Each Sheet In Sheets
    
    IsPrint = False

    dashLocation = InStr(1, Sheet.Name, "-")
        
    If dashLocation <> 0 Then
        
        num = Mid(Sheet.Name, 1, dashLocation - 1)

        IsPrint = True
        
    ElseIf IsNumeric(Sheet.Name) Then
    
        num = Val(Sheet.Name)
    
        IsPrint = True
    
    End If
    
    If IsPrint = True Then
    
        With Sheets(1)
            
            r = 5
            
            If .Range("W" & r + num) = "＃" Then
                
                FIleCopies = .Cells(r + num, PrintCol)
            
            Else
        
                FIleCopies = .Cells(r + num, PrintCol) + 2
        
            End If
            
            FileName = .Cells(r + num, 2)
            
        End With
            
        Debug.Print FileName & ":" & FIleCopies

        If FIleCopies <> 0 Then
        
            Sheet.Activate
        
            If msg = vbYes Then
        
                Sheet.PrintOut copies:=FIleCopies, preview:=True
        
            Else
            
                Sheet.PrintOut copies:=FIleCopies, preview:=False
            
            End If
        
        End If

    End If

Next

End Sub

Sub sortvba()

For i = 1 To 16

    For Each Sheet In Sheets
    
        shn = Sheet.Name
        
        If shn Like "*-*" Then
        
            pt = InStr(1, shn, "-")
            
            shn = Mid(shn, 1, pt - 1)
        
            If Val(shn) = i Then Sheet.Move after:=Sheets(Sheets.Count)
        
        End If
        
        If IsNumeric(shn) Then
        
            If Val(shn) = i Then Sheet.Move after:=Sheets(Sheets.Count)
        
        End If
        
    Next

Next

End Sub

留言

張貼留言

Popular Posts

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

圖片
***如需施工日誌請參考 這裡 *** 20250106更新: 新的部落格連結 新版本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")中點選"列印查驗"，     成果將輸出到該目錄下的查驗表Out...
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表轉出至CAD

圖片
在進行施工設計時，常使用Excel來進行數據的運算，常見有： 主結構配筋的時候要試算鋼筋數量、長度、重量 → 鋼筋數量表 主結構重要數量核算 → 材料數量表 渠道使用明渠水理試算 → 水理因素表 當然需要的表格不僅有這些，還有拉力強度、彎距強度...等等的試算(在一些重要的結構物上)，但我也沒碰過故不清楚這部分。 在CAD中畫圖時，將Excel表轉至CAD檔方法有： 利用AutoCAD插入表格，然後導入Excel檔。 複製/貼上，將Excel要得區域複製，到AutoCAD中貼上。 利用第三方軟體，做AutoCAD與Excel橋接。 詳細圖片說明請參考 ：  營建的馬克與電腦 筆者認為第三方軟體也是需要花錢的，故寫了個VBA供大家參考使用： 下載連結：  ExcelToCAD_ConverceData.dvb 程式使用方法展示：       1.   輸入你要前往的工作表位置 ( 請輸入名稱索引 , 最前方的數字 ) ，按下 Enter          ※如果偵測到工作表的頁數超過一頁的話才會啟動詢問 2.  直接選擇你要轉換的連結區域後，按下 Enter 20190307更新: 上述的原始碼還是有一點寫太麻煩了，這次直接實作一個clsExcelToCAD物件並同時引用clsACAD物件，執行主要程序為ExportToCAD，偵測的內容是被框選到的儲存格，如果為合併儲存格則強迫畫外框，如果為單一儲存格則偵測是否上下左右邊界有無畫線，有畫線則有外框。 Private MyACAD As New clsACAD Const TXT_COE = 0.8 Const ROW_COE = 0.335 Const COL_COE = 2.1 Public lupt As Variant Private rng_start As Range Private rng_end As Range Private rng_first As Range Sub ExportToCAD() For Each rng In Selection ...
Read more »