VBA/Excel-實例系列-01-工作簿目錄生成

今天George 2017-04-15

展開全文

系統(tǒng)：Windows 10
軟件：Excel 2010

這個系列說一些使用Excel/VBA具體的一些實例
今天講講如何使用VBA代碼自動為工作簿建立目錄

Part 1：為什么整這個？

不知大家有無遇到這樣的情況，手頭上有一個含有很多工作表的工作簿，由于工作需要，需要在這些工作表中查找信息或者操作
著實心累，有一天突發(fā)奇想，能不能自動建立一個目錄工作表，建立超鏈接，可以增加一些注釋，想點哪個工作表點哪一個
又想了下，能不能整成通用型，下次有新的工作表也一樣可以用，類似于一個小工具
好吧，實際的需求是促進技術發(fā)展的大大動力，希望各位看官，也有這樣的想法，遇見麻煩重復的事，多想想，能不能自動化

Part 2：框架搭建

需求：建議一個工作表“目錄”，主要內容為四列，包括：序號，含義，工作表名稱，超鏈接

由于想其它工作表也可以使用，所以把所有代碼放于一個模塊中，其它工作表使用直接導入即可
對于用戶的操作為：導入模塊bas文件，運行，刪除該模塊，保存，工作完成

代碼邏輯過程

檢查當前工作簿是否含有目錄工作表，有則提醒，并停止程序（這種情況下，用戶需手動更改原目錄工作表為其它名稱）
若當前工作簿無“目錄”工作表，則新建目錄工作表，并將該工作表位置放于首位
循環(huán)當前工作簿所有工作表，獲取名稱，置于目錄工作表C列中，并建立超鏈接，放置于D列，A列設置序號，B列可寫一下對工作表的注釋
調整一下單元格格式大小

代碼完成后，導出為模塊bas文件，其余用戶依然可用

效果圖

Part 3：代碼部分

Sub 各工作表名稱()
    Rem>>\該程序會新建一個工作表“目錄”，并置于第一個工作表位置
    Rem>>\獲得當前工作簿除“目錄”工作表以外的工作表名稱
    Rem>>\工作表名稱存放于“目錄”工作表C列，從第2行開始
    Rem>>\“目錄”工作表A列，存放序號；B列存放“含義”；D列存放超鏈接
    Rem>>\最多可以獲取9999個工作表目錄
    Rem>>
    For Each sht In ThisWorkbook.Worksheets
        shtName = sht.Name
        If shtName = '目錄' Then
            MsgBox '本工作簿已存在《目錄》工作表，請確認' & Chr(13) & Chr(10) _
            & '請手動刪除該工作表或者對其更名，將新建一個新的《目錄》工作表'
            End
        End If
    Next

    '新建目錄
    ThisWorkbook.Sheets(1).Select
    Sheets.Add
    ActiveSheet.Name = '目錄'
    Set shtContent = ThisWorkbook.Worksheets('目錄')
    shtContent.Move before:=ThisWorkbook.Sheets(1)

    shtContent.Cells.ClearContents
    shtContent.Range('A1') = '序號'
    shtContent.Range('B1') = '含義'
    shtContent.Range('C1') = '工作表名稱'
    shtContent.Range('D1') = '超鏈接'

    strNewWbName = ThisWorkbook.Name

    For Each sht In ThisWorkbook.Worksheets
        shtName = sht.Name
        If shtName <> '目錄' Then
            For intI = 2 To 10000 Step 1
                If shtContent.Cells(intI, 'C') = '' Then
                    shtContent.Cells(intI, 'A') = intI - 1
                    shtContent.Cells(intI, 'C') = shtName

                    strHyperLink = 'HYPERLINK(' & Chr(34) & '[' & strNewWbName & ']' & _
                    shtName & '!A1' & Chr(34) & ',' & Chr(34) & shtName & Chr(34) & ')'

                    shtContent.Cells(intI, 'D') = '=' & strHyperLink
                    Exit For
                End If
            Next
        End If
    Next

    '調整單元格
    shtContent.Rows.AutoFit
    shtContent.Columns.AutoFit

    shtContent.Columns('B:B').ColumnWidth = 20

    With shtContent.Cells
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With

End Sub

代碼截圖

Part 4：部分代碼解讀

shtContent.Move before:=ThisWorkbook.Sheets(1)，將工作表置于工作簿第一個
超鏈接函數(shù)HYPERLINK，用法為HYPERLINK(超鏈接地址，顯示的名字)，例如=HYPERLINK('[test.xlsx]Sheet1!A1','Sheet1')