Excel VBA 巨集程式分享程式分享~自動拆分工作表、自動插入行列與文字、所有工作表另存獨立Excel檔、自動刪除工作表

最近小編公司總務常常為了 Excel 做成的資產盤點表，要整理成各個分公司各部門需要的盤點表格，搞的七暈八素的，尤其是碰到大公司有上百個分公私部門單位時，光分工作表都分到快哭出來，請小編想想有沒有什麼方法可以更快速的解決他們的問題！先來放上模擬這樣的盤點 Excel 表格。

Excel 版本： Office 2019 中小企業版本 x64
在來這份 Excel 工作表需求如下：
1. 需在「名稱（各部門含地區）篩選拆分各個工作表，如上圖「台北工程部」、「台北財務部」、「台中工程部」 … 等等，工作表名稱就為該欄位中的名稱。
2. 在拆分的各部門盤點表要插上表頭並加入文字「設備盤點表（截至日期）」，日期要手動輸入特定日期。
3. 在拆分的各部門盤點表中「盤點」下方插入一行並加入文字「符合 Y」、「不符 N」。
4. 在「整組」、「資產標籤」、「閒置堪用」、「閒置不堪用」下方插入一行並加入文字「V」。
5. 在拆分的各部門盤點表另存成單獨的 Excel 檔，檔名為工作表的名稱。
6. 完成後，把先前篩選拆分出來的工作表全部刪除，留下原來的總盤點表。

OK，這幾個需求其實現在很多企業的資產系統中就可以很輕鬆的篩選出來，亦即這些都算是基本的功能了！但畢竟不是很多企業都有很完整的資產系統，多半還是要靠半手工方式完成，像這份總盤點表就是從 ERP 系統匯出來，然後再用 Excel 來完成。所以小編透過 Excel 巨集的功能，快速完成上述幾點重複、繁鎖的需求。

當然也有人會題到巨集就透過「錄製巨集」在「重複播放」就搞定啦，但路下來就是會漏漏長的程式碼，要修改又要花時間去重錄，所以就直接分享給有類似需求的朋友。

在來提到巨集，是使用Visual Basic Application（VBA）來寫，比傳統的程式語言（C 或 Java）相比，簡單明瞭！很輕鬆就可以上手喔！若你有其他特殊需求也可以在留言提出，小編會在幫忙看看，廢話不多說快來看看怎麼做。

一. 如何開啟巨集：
點選左上角的下單選單中「其他命令」，會進入「Excel選項」的視窗，點選左側的「自訂功能區」，再勾選裡面的「開發人員」選項，最後按下「確定」。

二. 如何新增巨集：
點選「檢視」裡面最右邊「巨集」。輸入「巨集名稱」、設定快捷鍵、設定儲存位置以及增加描述。

三. 撰寫需求的 VBA 程式碼及執行效果：
1. 按特定欄位拆分工作表：
程式碼如下，巨集名稱 AutoRaw2Sheet：

Sub AutoRaw2Sheet()
    MsgBox "確認拆分各分公司部門盤點清單為各Sheet", 0 + 64
    Dim myRange As Variant
    Dim myArray
    Dim titleRange As Range
    Dim title As String
    Dim columnNum As Integer
    myRange = Application.InputBox(prompt:="請選擇標題行", Type:=8)
    myArray = WorksheetFunction.Transpose(myRange)
    Set titleRange = Application.InputBox(prompt:="請選擇拆分的表頭", Type:=8)
    title = titleRange.Value
    columnNum = titleRange.Column
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Dim i&, Myr&, Arr, num&
    Dim d, k
    For i = Sheets.Count To 1 Step -1
        If Sheets(i).Name <> "總盤點表" Then
            Sheets(i).Delete
        End If
    Next i
    Set d = CreateObject("Scripting.Dictionary")
    Myr = Worksheets("總盤點表").UsedRange.Rows.Count
    Arr = Worksheets("總盤點表").Range(Cells(2, columnNum), Cells(Myr, columnNum))
    For i = 1 To UBound(Arr)
        d(Arr(i, 1)) = ""
    Next
    k = d.keys
    For i = 0 To UBound(k)
        Set conn = CreateObject("adodb.connection")
'        conn.Open "provider=microsoft.jet.oledb.4.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        conn.Open "provider=microsoft.ACE.oledb.12.0;extended properties=excel 8.0;data source=" & ThisWorkbook.FullName
        Sql = "select * from [總盤點表$] where " & title & " = '" & k(i) & "'"
        Worksheets.Add after:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = k(i)
            For num = 1 To UBound(myArray)
                .Cells(1, num) = myArray(num, 1)
            Next num
            .Range("A2").CopyFromRecordset conn.Execute(Sql)
        End With
        Sheets(1).Select
        Sheets(1).Cells.Select
        Selection.Copy
        Worksheets(Sheets.Count).Activate
        ActiveSheet.Cells.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
                               SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False
    Next i
    conn.Close
    Set conn = Nothing
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Sheets("總盤點表").Select
    Range("E1").Select
End Sub

新增完成後執行該巨集。

先選擇標題行。

在選擇要拆分的欄位表頭，注意只要選擇那個表頭，不要整欄都選。

結果就會按拆分的欄位「名稱」，變成各個工作表囉。

2. 在所有的工作表插入特定行與文字，排除第一頁（總盤點表）。
程式碼如下，巨集名稱 InsertTitle：

Sub InsertTitle()
MsgBox "確認將各分公司部門盤點清單插入表頭", 0 + 64
Dim x, y, z
On Error Resume Next
x = InputBox("請輸入日期（格式2021/02/27)：")

For z = 2 To Worksheets.Count '在所有工作表中循環執行
Sheets(z).Select

Range("A1:M1").Select
Selection.Insert
Selection.Merge
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
Range("A1:M1").Select
ActiveCell.FormulaR1C1 = "設備盤點表（截至" + x + "止)"
With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = True
End With

Rows("3:3").Select
Selection.Insert
Range("A2:A3").Select
Selection.Merge
Range("B2:B3").Select
Selection.Merge
Range("C2:C3").Select
Selection.Merge
Range("D2:D3").Select
Selection.Merge
Range("E2:E3").Select
Selection.Merge
Range("F2:F3").Select
Selection.Merge
Range("M2:M3").Select
Selection.Merge
Range("G3").Select
ActiveCell.FormulaR1C1 = "符合Y"
Range("H3").Select
ActiveCell.FormulaR1C1 = "不符N"
Range("I3").Select
ActiveCell.FormulaR1C1 = "V"
Range("J3").Select
ActiveCell.FormulaR1C1 = "V"
Range("K3").Select
ActiveCell.FormulaR1C1 = "V"
Range("L3").Select
ActiveCell.FormulaR1C1 = "V"

Range("F2:L3").Select
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
    .LineStyle = xlContinuous
    .ColorIndex = 0
    .TintAndShade = 0
    .Weight = xlThin
End With

Next

Sheets("總盤點表").Select
Range("E1").Select

End Sub

新增完成後執行該巨集。

輸入特定日期。

結果完成插入特定行和文字囉。

3. 在所有的工作表另存獨立 Excel 檔，當名為工作表名稱，排除第一頁（總盤點表）。
程式碼如下，巨集名稱 AllSheet2file：

Sub SaveSheetAsWorkbook()
Dim Sht As Worksheet
MsgBox "確認各分公司部門盤點清單Sheet各存成獨立的Excel檔", 0 + 64
    For Each Sht In Sheets
    If Sht.Name <> "總盤點表" Then
        Sht.Copy
        ActiveWorkbook.SaveAs ThisWorkbook.Path & "\" & Sht.Name & ".xls"
        ActiveWorkbook.Close
    End If
    Next

Sheets("總盤點表").Select
Range("E1").Select
End Sub

新增完成後執行該巨集。

結果就在原目錄下產生各獨立 Excel 檔囉。

4. 除第一頁（總盤點表）外，其他的工作表一次全數刪除。
程式碼如下，巨集名稱 ClearSheet：

Sub ClearSheet()
Dim Sht As Worksheet
MsgBox "確認清除舊有各分公司部門盤點清單Sheet", 0 + 64
    For Each Sht In Sheets
    If Sht.Name <> "盤點清單" Then
        Application.DisplayAlerts = False
        Sht.Delete
        Application.DisplayAlerts = True
    End If
    Next
    Application.DisplayAlerts = True

Sheets("總盤點表").Select
Range("E1").Select
End Sub

新增完成後執行該巨集。

結果就會發現只剩下一開始原來的工作表囉。

四. 注意事項：
1. 小編在四個巨集執行時都會跳出警告訊息，說明這個巨集是要做什麼動作！避免不小心執行錯誤。
2. 巨集新增完成後，存檔時注意檔案類型（副檔名）只能存「.xlsm」不能存「.xls」，不然擬新增好的巨集 VBA 程式碼不會跟著存進去喔！

OK，今天就先這四個 VBA 程式，分享一下四支程式執行過程。後面若還有同事需求時，小編在分享出來，若你也有其他需求要幫忙，在留言處留言，小編在幫你看看喔！