一、對象模型
在VBE中“幫助（H）”——“Microsoft Visual Basic 幫助（H） F1”——“Visual Basic 語言參考”——“函數” 或者在VBE下快捷鍵“F1”
位址：https://docs.microsoft.com/zh-cn/office/vba/api/overview/excel/object-model
二、Application對象（Excel頂層對象）
1、ScreenUpdating屬性
是否控制螢幕更新，False表示關閉螢幕更新，True表示打開螢幕更新
設定ScreenUpdating=False 關閉螢幕更新，将看不到程式的執行過程，可以加快程式的執行速度，讓程式顯得更直覺，專業。
示例（為關閉螢幕更新下，會彈出對話框）：
Sub InputTest()
Cells.ClearContents '清除表中所有資料
Range("A1:A10") = 100
MsgBox "剛才在A1:A10輸入數值100，你能看到結果嗎？"
Range("B1:B10") = 200
MsgBox "剛才在B1:B10輸入數值200，你能看到結果嗎？"
End Sub 示例（關閉螢幕更新，看不到執行過程，程式最終執行完成才能看到最終結果）
Sub InputTest()
Cells.ClearContents '清除表中所有資料
Application.ScreenUpdating = False '關閉螢幕更新
Range("A1:A10") = 100
MsgBox "剛才在A1:A10輸入數值100，你能看到結果嗎？"
Range("B1:B10") = 200
MsgBox "剛才在B1:B10輸入數值200，你能看到結果嗎？"
Application.ScreenUpdating = True '恢複螢幕更新
End Sub 2、DisplayAlterts屬性
是否顯示警告對話框，False為不顯示，True為顯示
Sub delSht()
Dim sht As Worksheet
Application.DisplayAlerts = False '不顯示警告資訊
For Each sht In Worksheets
If sht.Name = ActiveSheet.Name Then '判斷sht是不是活動工作表
sht.Delete '删除sht代表的工作表
End If
Next
Application.DisplayAlerts = True '恢複顯示警告資訊
End Sub 3、EnableEvents屬性
啟用或禁用事件，False為禁用（不讓事件發生），True為啟用
什麼是事件？能被Excel認識的一個操作動作，例如“打開工作簿”、“關閉工作簿”等
- 示例1：編寫一個程式，當選中工作表的單元格時，自動在單元格中寫入該單元格的位址
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Target.Value = Target.Address
End Sub - 示例2：選中活動單元格，記錄對應單元格位址，并将活動單元格向下移動一個單元格
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Target.Value = Target.Address
Application.EnableEvents = False '禁用事件
Target.Offset(1, 0).Select '選中活動單元格下面的一個單元格
Application.EnableEvents = True '啟用事件
End Sub 4、WorksheetFunction屬性
使用WorksheetFunction調用Excel内置函數
- 示例1：統計A1:A50單元格中數值大于1000的單元格有多少個？
Sub CountTest()
Dim mycount As Integer, rng As Range
For Each rng In Range("A1:B50")
If rng.Value > 1000 Then mycount = mycount + 1
Next
MsgBox "A1:B50中大于1000的單元格個數為:" & mycount
End Sub - 示例2： 統計A1:A50單元格中數值大于1000的單元格有多少個？使用COUNTIF函數
Sub CountTest()
Dim mycount As Integer
mycount = Application.WorksheetFunction.CountIf(Range("A1:B50"), ">1000")
MsgBox "A1:B50中大于1000的單元格個數為:" & mycount
End Sub 5、給Excel梳妝打扮
- Excel工作表界面相關指令
- Excel界面
6、Application的常用屬性
三、Workbook對象
Workbook工作簿
Workbooks工作簿集合
1、怎麼引用工作簿
引用工作簿，就是指明工作簿的位置及名稱，共有兩種方式
方式一：利用索引号引用工作簿，Workbook.Item(3)，這裡的Item可以省略，即Workbook(3)
方式二：利用工作簿名稱引用 ，Workbook("Book1")或Workbook("Book1.xls")，如果本地檔案顯示拓展名（且檔案已經儲存），則檔案名必須帶拓展名，否則會報錯。
2、Workbook名片資訊
Sub wbMsg()
Range("B2") = ThisWorkbook.Name '傳回目前工作簿名稱 練習 -副本.xlsm
Range("B3") = ThisWorkbook.Path '傳回目前工作簿路徑 C:\Users\ThinkPad\Desktop
Range("B4") = ThisWorkbook.FullName '傳回當期工作簿帶名稱的路徑 C:\Users\ThinkPad\Desktop\練習 - 副本.xlsm
End Sub 3、建立工作簿
- 使用方法：Workbooks.Add
如果不帶任何參數，将建立包含一定數目空白工作表的新工作簿（數目由SheetsInNewWorkbook屬性決定）
- 也可以給Add方法設定參數(參數表示現有Excel名稱的字元串，選用該參數，建立的工作簿将以該檔案作為模闆)
Workbooks.Add "C:\Program Files\Microsoft Office\Templates\2052\ADDRESS\ADDRESS.XLS"
- 也可以通過參數指定建立工作簿中包含的工作類型
Workbooks.Add xlWBATChart '建立圖表工作表
- Excel一共有4種類型的工作表
可以在插入對話框裡看到(選中工作表名稱——滑鼠右鍵單擊——插入——即可顯示)，如圖（包含參數說明）：
4、打開工作簿
使用Workbooks的Open方法（參數名要寫含路徑的名稱）
Sub OpenFile()
Workbooks.Open Filename:="F:\Book1.xls"
End Sub 參數名成可以省略不寫(Open除了Filename參數外，還有14個參數，讓使用者決定以何種方式打開指定的檔案，可以通過系統的幫助來檢視更多的資訊)
Sub OpenFile()
Workbooks.Open "F:\Book1.xls"
End Sub 5、激活工作簿
同僚打開多個工作簿，但是同一時間隻能有一個視窗是活動的，調用Workbooks對象的Active方法可以激活一個工作簿。
Sub JhWb()
Workbooks("Book1.xls").Activate '激活工作簿
End Sub 6、儲存工作簿
儲存工作簿調用Workbooks的Save方法
Sub SaveWb()
ThisWorkbook.Save '儲存代碼所在的工作簿
End Sub 如果想将檔案另存為一個新的檔案，或者第一次儲存一個建立的工作簿，就用SaveAs方法。
參數指定檔案儲存的路徑及檔案名如果省略路徑，則預設将檔案儲存在目前檔案夾中
Sub SaveWb()
ThisWorkbook.SaveAs Filename:="D:\test.xls"
End Sub 使用SaveAs方法将工作簿另存為新檔案後，将自動關閉原檔案，打開新檔案，如果希望繼續保留原檔案不打開新檔案，可以用SaveCopyAs方法
Sub SaveWb()
ThisWorkbook.SaveCopyAs Filename:="D:\test.xls"
End Sub 7、關閉工作簿
關閉工作簿使用Workbooks的Close方法，如果不帶參數，則關閉所有打開的工作簿
Sub CloseWb()
Workbooks.Close '關閉所有打開的工作簿
End Sub 如果想關閉指定的工作簿，需要指定參數
Sub CloseWb()
Workbooks("Book1.xls").Close '關閉Book1.xls
End Sub 如果關閉之前被更改過的内容沒有儲存，關閉工作簿前Excel會詢問使用者是否儲存更改，如果不想顯示該對話框，可以給Close方法設定參數：
Sub CloseWb()
Workbooks("Book1.xls").Close savechanges:=True '關閉并儲存Book1.xls
End Sub 關閉并儲存的參數savechanges也可以省略不寫：
Sub CloseWb()
Workbooks("Book1.xls").Close True '關閉Book1.xls
End Sub 8、ThisWorkbook與ActiveWorkbook
同是Application對象的屬性，同是傳回Workbook對象，但二者并不是等同的。
ThisWorkbook是對程式所在的工作簿的引用
ActiveWorkbook是對活動工作簿的引用
建立的工作簿總會成為活動工作簿
Sub wb()
Workbooks.Add
MsgBox "代碼所在的工作簿為：" & ThisWorkbook.Name & Chr(13) _
& "目前活動工作簿為：" & ActiveWorkbook.Name
ActiveWorkbook.Close savechanges:=False
End Sub 四、Worksheet對象
Worksheet表示一張普通的工作表，Worksheets表示多個Worksheet對象的集合。
1、引用工作表
可以使用工作表的索引号或者标簽名稱引用它
Worksheets.Item (1) '引用工作表裡的第一張工作表
Worksheets (1) '引用工作表裡的第一張工作表
Worksheets ("Sheet1") '引用工作簿裡标簽名稱為"Sheet1"的工作表 因為代碼名稱隻能在【屬性視窗】裡修改，不會随着工作表标簽名稱或索引号的變化而變化。是以，當工作表的索引号或标簽名稱經常變化時，使用代碼名稱引用工作表會更友善。
使用代碼名稱引用工作表，隻需直接寫代碼名稱
例如：第一張工作表的A1單元格輸入100，代碼為：Sheet1.Range("A1")=100
檢視工作表的代碼名稱，可以讀取它的CodeName屬性，如果想知道活動工作表的代碼名稱，代碼為：
Sub ShowShtCode()
MsgBox ActiveSheet.CodeName
End Sub 2、建立工作表
建立工作表使用Worksheets的Add方法
- 不帶任何參數，将在活動工作表建立一張工作表
Worksheets.Add
- 可以用參數給建立的工作表指定位置
Worksheets.Add before:=Worksheets(1) '在第一張工作表前插入一張新的工作表
Worksheets.Add after:=Worksheets(1) ‘在第一張工作表後插入一張新的工作表
- 還可以同時插入多張工作表
Worksheets.Add Count:=3 '在活動工作表前插入3張工作表，Count參數的預設值為1
- 可以同時使用多個參數，不同參數之間用英文逗号隔開
Sub shtAdd()
Worksheets.Add after:=Worksheets(1), Count:=3
End Sub 在最後一張工作表後插入兩張工作表
Sub shtAdd()
'在最後一個工作表後插入兩張工作表
Worksheets.Add before:=Worksheets(Worksheets.Count), Count:=2
End Sub - Add方法有哪些參數？請看VBE的提示
3、更改工作表标簽名稱
- 更改工作表标簽名稱，設定工作表Name屬性
Worksheets(2).Name="工資表" '更改第二張工作表的标簽名稱為“工資表”
- 建立工作表時在程式中更改标簽名稱
Sub shtAdd()
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "工資表"
End Sub - 建立工作表同時指定它的标簽名稱
Sub shtAdd()
'在第一張工作表前插入一個名稱為“工資表”的工作表
Worksheets.Add(before:=Worksheets(1)).Name = "工資表"
End Sub - 如果同時添加多張工作表（即Count參數值大于1），并不能使用一句代碼同時命名
4、删除工作表
删除工作表使用Worksheets對象的Delete方法
Worksheets("Sheet1").Delete '删除Sheet1工作表
5、激活工作表
激活工作表可以使用Activate方法和Select方法
Worksheets(1).Activate '激活第一張工作表
Worksheets(1).Select '激活第一張工作表
6、複制工作表
複制工作表使用Copy方法
Sub shtCopy()
'這裡的工作表名稱一定要存在，否則執行會報錯
Worksheets("工資條").Copy '不帶參數 複制工作表，同時建立工作簿用于存放copy來的工作表（未儲存狀态）
Worksheets("工資條").Copy before:=Worksheets("Sheet1") '帶參數 複制工作表，存放在目前工作簿的工作表Sheet1之前
Worksheets("工資條").Copy after:=Worksheets("Sheet1") '帶參數 複制工作表，存放在目前工作簿的工作表Sheet1之後
End Sub 7、移動工作表
移動工作表與複制工作表類似，使用方法Move
Sub shtMove()
Worksheets("工資條").Move '不指定參數，将把工作表移動到新的工作簿中（建立工作簿）
Worksheets("工資條").Move before:=Worksheets("Sheet1") '複制工作表，存放在目前工作簿的工作表Sheet1之前
Worksheets("工資條").Move after:=Worksheets("Sheet1") '複制工作表，存放在目前工作簿的工作表Sheet1之後
End Sub 8、隐藏和顯示工作表
使用工作表的Visible屬性顯示或隐藏工作表
'以下這三行代碼作用一樣，等同于從【格式】菜單中隐藏工作表
Worksheets("工資條").Visible = False
Worksheets("工資條").Visible = xlSheetHidden
Worksheets("工資條").Visible = 0 用下面方法隐藏的工作表，跟上面3種方法不一樣，且通過這種方法隐藏的工作表，無法通過菜單取消隐藏，隻能通過VBA在屬性視窗設定或者用代碼取消隐藏
Worksheets("工資條").Visible = xlSheetVeryHidden
Worksheets("工資條").Visible = 2 無論以何種方式隐藏了工作表，都可以用如下代碼中的任意一句顯示它
Worksheets("工資條").Visible = True
Worksheets("工資條").Visible = xlSheetVisible
Worksheets("工資條").Visible = 1
Worksheets("工資條").Visible = -1 9、擷取工作表的數目
使用Worksheets.Count
Dim mycount%
mycount=Worksheets.Count 10、Sheets與Worksheets
- 不同的指令，傳回相同的結果
Sheets(2).Name
Worksheets(2).Name
Sheets.Count
Worksheets.Count - 分别代表兩種不同的集合
Excel裡共有4中不同類型的工作表，Sheets表示公祖不裡所有類型的工作表的集合，而Worksheets隻表示普通工作表的集合。
Sheets和Worksheets集合裡的對象都有标簽名稱Name、代碼名稱CodeName、索引号Index等屬性，也有Add、Delete、Copy和Move等方法，設定屬性和調用方法類似。但是因為Sheets集合包含更多類型的工作表，所有其包含的方法和屬性比Worksheets集合多。
五、Range對象
1、Worksheet(或Range)對象的Range屬性
- 引用單元格并指派
Worksheets("sheet1").Range("A1").Value=50
Sub rng()
Range("A1:A10").Value = 200 '在活動工作表的A1:A10輸入值為200
Dim n As String
n = "B1:B10"
Range(n) = 100 '在活動工作表的B1:B10輸入值為100
End Sub - 通過設定“單元格區域名稱”調用Range
Sub rng()
Range("date").Value = 200
End Sub - 引用多個不連續的區域，用逗号隔開
Sub rng()
Range("A1:A10,A4:E6,C3:D9").Value = 200
End Sub - 用空格而不是逗号，則表示選中區域交集部分
Sub rng()
Range("A1:B10 A4:D9").Value = 200
End Sub 2、Worksheet(或Range)對象的Cells屬性
- 指定單元格
Sub shtCells()
ActiveSheet.Cells(3, 4).Value = 20 '在第3行，第4列香蕉的單元格輸入20
ActiveSheet.Cells(3, "D").Value = 30 '在第3行，第D列相交的單元格輸入30
Range("B3:F9").Cells(2, 3) = 40 '在區域“B3:F9”區域中的第2行，第3列相交的單元格，即D4
ActiveSheet.Cells(2).Value = 50 '在活動工作表的第二個單元格輸入50,這裡使用的數字2是單元格序号，序号是按照單元格區域内由左向右遞增
'選中活動工作表的A1:E10
Range(Cells(1, 1), Cells(10, 5)).Select
'以下兩個語句等價
Range("A1", "E10").Select
Range(Range("A1"), Range("E10")).Select
End Sub - 全部單元格
Sub shtCells()
ActiveSheet.Cells.Select '選中活動工作表的所有單元格
Range("B3:E9").Select '選中活動工作表中B3:E9單元格區域
End Sub - 更簡短的快捷方式
Sub shtCells()
[A1] = 10
[A1:B10] = 20
[B3:D10 A4:G8] = 100 '公共交叉區域，如果兩個區域參數沒有逗号，表示一個參數，而參數表示的區域沒有交集的話會報錯
[A1:A10,C1:C10,E1:E10] = 200 '合并區域
[area] = 300 '名稱are代表單元格，即單元格名稱為area
End Sub []是Application對象的Evaluate方法的簡寫形式，這種簡寫形式非常适合飲用一個固定的Range對象，但是因為不能再方括号中使用變量，是以這種引用方式缺少靈活性。
4、其他擷取單元格的方式（除了Range、Cells外）—Rows
ActiveSheet.Rows '選中活動工作表的所有行
ActiveSheet.Rows(3).Select '選中活動工作表的第3行
ActiveSheet.Rows("3:3").Select '選中活動工作表的第3行
ActiveSheet.Rows("3:5").Select '選中活動工作表的第3行到第5行
Rows("3:10").Rows("1:1").Select '選中第3行到第10行區域内的第一行 5、其他擷取單元格的方式（除了Range、Cells外）—Columns
ActiveSheet.Columns '選中活動工作表的所有列
ActiveSheet.Columns (6) '選中活動工作表中的第6列
ActiveSheet.Columns ("F:G") '選中活動工作表中的F至G列
Columns("B:G").Columns("B:B").Select '選中B:G區域中的第2列 6、Application的Union方法
Union方法像一支強烈的粘合劑，将不連續的多個單元格區域粘在一起，可以同時對其進行操作。
Sub rngUnion()
Application.Union(Range("A1:A10"), Range("D1:D5")).Select '入參至少為2個區域，至多30個區域，區域之間用逗号分隔
Union(Range("A1:A10"), Range("D1:D5")).Select 'application可以省略不寫
End Sub 7、Range對象的Offset屬性
Offset屬性用來基于基于單元格的位置移動
Offset(x,y)兩個參數，x表示行移動，即x>0表示向下移動，x<0表示向上移動；y表示列移動，即y>0表示向右移動，y<0表示向左移動。
參數移動方向示意圖：
Sub rngOffset()
Range("A1").Offset(2, 3).Value = 500 '基于“A1”單元格，向下移動2行，向右移動3列
Range("C5:D6").Offset(-3, 0).Select '在“C5：D6”區域的基礎上，向上移動3行，列方向參數為0，不移動。
End Sub 8、Range對象的Resize屬性
使用Range對象的Resize屬性擴大或縮小指定的單元格區域，得到一個新的單元格區域。
Resize共有兩個參數，第一個參數确定新區域的行數，第二個參數确定新區域的列數，兩個參數的值都是正整數，最小為1.
新區域把該對象最左上角的單元格當成自己左上角第一個單元格
Sub rngResize()
'将B2單元格擴大為B2:E6
Range("B2").Resize(5, 4).Select
'将B2：E6單元格縮小為B2：B3，新區域以B2單元格為最左上角單元格
Range("B2:E6").Resize(2, 1).Select
'上句等同于
Range("B2:E6").Cells(1).Resize(2, 1).Select
End Sub 9、Worksheet對象的UsedRange屬性
UsedRange屬性傳回工作表中已經使用的單元格圍成的矩形區域（不管這些區域間是否有空行，空列或空單元格）。
Sub rngUsed()
ActiveSheet.UsedRange.Select
End Sub 10、Range對象的CurrentRegion屬性
CurrentRegion傳回目前區域，即以空行和空行的組合為邊界的區域
Sub rngUsed()
Range("D3").CurrentRegion.Select
End Sub 11、Range對象的End屬性
End屬性傳回目前區域結尾處的單元格，等同于在源單元格按<End+方向鍵（上下左右）>得到的單元格。
Sub rngEnd()
Range("E5").End(xlUp).Select
End Sub 共有4個參數，說明如下：
什麼情況會用到End屬性？工作表中記錄的行數随時都在變化，應該把新記錄寫入工作表的第5行還是第10行？
可以用End屬性解決這個問題
Sub rngEnd()
'取第一個單元格，如果非空則向下移動一個單元格，否則不移動。對新單元格進行指派
Dim c As Range
Set c = ActiveSheet.Range("A65536").End(xlUp)
If c.Value <> "" Then
Set c = c.Offset(1, 0)
End If
c.Value = "張青"
End Sub
Sub rngUsed()
'取使用區域内行數增加1，對該行的A列進行指派
Dim xrow As Long
xrow = ActiveSheet.UsedRange.Rows.Count + 1
Cells(xrow, "A").Value = "張青"
End Sub
Sub rngCurr()
'取目前區域内行數增加1，對該行的A列進行指派
Dim xrow As Long
xrow = Range("A1").CurrentRegion.Rows.Count + 1
Cells(xrow, "A").Value = "張青"
End Sub 六、操作單元格，還需要了解
1、單元格内容-Value
Range("A1:B2").Value = "abc"
Range("A1:B2") = "abc" 'Value是Range的預設屬性，在給區域指派時可以省略。 2、單元格個數-Count
Range("B4:F10").Count '統計單元格數量
ActiveSheet.UsedRange.Rows.Count '統計活動單元格的行數
ActiveSheet.UsedRange.Columns.Count '統計活動單元格的列數 3、單元格位址-Address
MsgBox "目前選中的單元格位址為"&Selection.Address
4、選中單元格-Active與Select
以下兩組代碼是等效的。
ActiveSheet.Range("A1:B10").Select
ActiveSheet.Range("A1:B10").Activate 5、選擇性清除單元格-Clear
Range("B2:B15").Clear '清除B2:B15單元格所有内容（包括批注、内容、注釋、格式等）
Range("B2:B15").ClearComments '清除B2:B15單元格批注
Range("B2:B15").ClearContents '清除B2:B15單元格内容
Range("B2:B15").ClearFormats '清除B2:B15單元格格式 6、複制&粘貼單元格區域-Copy&Paste
- 錄制複制和粘貼的宏内容如下：
Sub Macro1()
Range("A1").Select
Selection.Copy
Range("C1").Select
ActiveSheet.Paste
End Sub - 但在執行複制或者粘貼操作之前并不需要選中單元格，是以代碼可以簡化為：
Sub Macro1()
Range("A1").Copy Range("C1") 'A1是源單元格，C1是目标單元格
End Sub - 帶參數的複制-Destination
Sub Macro1()
Range("A1").Copy Destination:=Range("C1") 'A1是源單元格，C1是目标單元格,Destination是目标
End Sub - 帶參數的複制-CurrentRegion
要複制的單元格區域不能确定大小，可以隻指定一個單元格作為目标區域的最左上角單元格
Sub Macro1()
Range("A1").CurrentRegion.Copy Range("C1") 'A1是源單元格，C1是目标單元格,Destination是目标
End Sub - 想粘貼源區域的數值（以下兩個式子等價）
Sub rngCopyValue_1()
Range("A1:A10").Copy
Range("F1:F10").PasteSpecial Paste:=xlPasteValues '僅粘貼數值
End Sub
Sub rngCopyValue_2()
Range("A1:A10").Value = Range("F1:F10").Value
End Sub 7、剪切單元格-Cut
Sub rngCut()
Range("A1:A5").Cut Destination:=Range("G1") '把A1:A5剪切到G1:G5，這裡G1表示以G1為左上角第一個單元格的區域
Range("F6:F10").Cut Range("G6") '把F1:F10剪切到G6:K10，參數Destination可以省略
End Sub 8、删除單元格-Delete
Delete有4個選項，分别對應如下參數：
Range("B5").Delete Shift:=xlToLeft '删除B5單元格，删除後右側單元格左移
Range("B5").Delete Shift:=xlUp '删除B5單元格，删除後下方單元格上移
Range("B5").EntireRow.Delete '删除B5單元格所在的行
Range("B5").EntireColumn.Delete '删除B5單元格所在的列 9、單元格名稱，Names集合
Excel中定義的名稱就是給單元格區域（或數值、常量、公式）取的名字，一個自定義的名稱及時一個Name對象，Names是工作簿中定義的所有名稱的集合。
- 建立名稱
錄制的宏告訴我們，怎樣建立一個名稱
'Add建立名稱的方法，RefersToR1C1表示使用R1C1引用樣式
ActiveWorkbook.Names.Add Name = "date", RefersToR1C1:="Sheet1!R5C[-2]" R5C[-2]說明：R後面的數值表示行号，C後面的數值表示列号，[]中括号表示相對引用，預設是絕對引用，相對應用時R>0表示向下移動，C>0表示向右移動
R[2]C[3]：對活動單元格下方的第二行與右邊的第3列相交的單元格的引用
R2C3：對工作表中第二行與第3列相交的單元格的引用
- 另一種單元格引用方式：A1樣式引用
'Add建立名稱的方法，RefersToR1C1表示使用A1引用樣式,$表示相對絕對引用，将把活動單元格當做A1單元格
ActiveWorkbook.Names.Add Name = "date", RefersTo:="Sheet1$B$4" - 定義名稱更簡單的方式
Range("A1:C10") = "date" - 怎樣引用名稱
ActiveWorkbook.Names("date").Name = "姓名"
ActiveWorkbook.Names("姓名").Name = "張三" - 也可以使用名稱索引引用名稱
Sub UseName()
Dim i, mx As Integer
mx = ActiveWorkbook.Names.Count '統計一共有多少個單元格
For i = 1 To mx
activateworkbook.Names(i).Visible = False '隐藏名稱
Next
End Sub 10、單元格批注，Comment對象
一個批注就是一個Comment對象，Comments是工作簿中所有Comment對象的集合
- 給單元格增加批注
Range("B5").AddComment Text:="我用VBA建立的批注" - 怎麼知道單元格是否有批注
Sub wbComment()
Range("B5").AddComment Text:="我用VBA建立的批注"
If Range("B5").Comment Is Nothing Then '判斷是否存在Comment對象
MsgBox "B5單元格中沒有批注"
Else
MsgBox "B5單元格中已有批注"
End If
End Sub - 操作批注
Sub operComment()
Range("B5").AddComment Text:="我用VBA建立的批注" '建立批注
Range("B5").Comment.Visible = False '隐藏B5單元格批注
Range("B5").Comment.Delete '删除B5單元格批注
End Sub 11、給單元格化妝
- 設定字型-Font
Sub FontSet()
With Range("A1:L1").Font
.Name = "宋體" '設定字型為宋體
.Size = 12 '設定字号為12号
.Color = RGB(255, 0, 0) '設定字型顔色為紅色
.Bold = True '設定字型加粗
.Italic = True '設定字型傾斜顯示
.Underline = xlUnderlineStyleDouble 'feud文字添加雙下劃線
End With
End Sub - 給單元格增加底紋-Interior
Sub InteriorSet()
Range("A1:L1").Interior.Color = RGB(255, 255, 0) '增加黃色底紋
End Sub - 給表格設定表框
Sub InteriorSet()
With Range("A1").CurrentRegion.Borders
.LineStyle = xlContinuous '設定單線邊框
.Color = RGB(0, 0, 255) '設定邊框顔色
.Weight = xlHairline '設定邊框線條樣式
End With
End Sub - 其他設定
可以在“單元格格式”對話框中進行其他設定，如果想用代碼實作而不知道代碼怎麼寫，可以手動操作，用宏錄制器錄下它。
七、典型的技巧與示例
1、編寫一個程式，按要求創求的一個新的工作簿，并把它儲存到指定的檔案夾。
Sub wbAdd()
'程式建立“員工花名冊”工作簿，儲存在本工作簿所在的檔案夾中
Dim wb As Workbook, sht As Worksheet '定義一個Workbook對象和一個Worksheet對象
Set wb = Workbooks.Add '建立一個工作簿
Set sht = wb.Worksheets(1)
With sht
.Name = "花名冊" '修改第一張工作表的标簽名稱
.Range("A1:F1") = Array("序号", "姓名", "性别", "出生年月", "參加工作時間", "備注") '設定表頭
End With
wb.SaveAs ThisWorkbook.Path & "\員工花名冊.xls" '儲存建立的工作表到本工作簿所在的檔案夾中
ActiveWorkbook.Close '關閉建立的工作簿
End Sub 2、判斷工作簿是否打開
- 工作簿是否打開判斷
'判斷"成績表.xls"工作簿是否打開
Sub isWbOpen()
Dim i As Integer
For i = 1 To Workbooks.Count
If Workbooks(i).Name = "成績表.xls" Then
MsgBox "檔案已打開"
Exit Sub '如果找到該檔案，退出過程
End If
Next
MsgBox "檔案沒有打開"
End Sub - 工作表是否打開判斷
'判斷打開的工作表中是否含“一年級”，有則移動到第一個位置，否則在第一個位置建立
Sub isShtOpen()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name = "一年級" Then
sht.Move before:=Worksheets(1)
'MsgBox "已經打開"
Exit Sub
End If
Next
Worksheets.Add(before:=Worksheets(1)).Name = "一年級"
End Sub 另一種寫法：
'判斷打開的工作表中是否含“一年級”，有則移動到第一個位置，否則在第一個位置建立 Sub isShtOpen()
On Error Resume Next
If Worksheets("一年級") Is Nothing Then
Worksheets.Add(before:=Worksheets(1)).Name = "一年級"
Else
Worksheet("一年級").Move before:=Worksheets(1)
'MsgBox "已經打開"
End If
End Sub 3、判斷工作簿是否存在
Sub isExistWb()
'判斷本工作簿所在的檔案夾中是否存在“員工花名冊.xls”
Dim fil As String
fil = ThisWorkbook.Path & "\員工花名冊.xls"
If Len(Dir(fil)) > 0 Then
MsgBox "工作簿已經存在"
Else
MsgBox "工作簿不存在"
End If
End Sub 4、向未打開的工作簿中錄入資料
Sub WbInput()
'在本工作簿所在的檔案夾下“員工花名冊”裡添加一條記錄
Dim wb As String, xrow As Integer, arr
wb = ThisWorkbook.Path & "\員工花名冊.xls"
Workbooks.Open (wb)
With ActiveWorkbook.Worksheets(1)
xrow = .Range("A1").CurrentRegion.Rows.Count + 1
arr = Array(xrow - 1, "張嬌", "女", "#7/8/1987#", "#9/1/2010#", "10年新招")
.Cells(xrow, 1).Resize(1, 6) = arr
End With
ActiveWorkbook.Close savechanges:=True
End Sub 5、隐藏活動工作表外的所有工作表
Sub ShtVisible()
'隐藏活動工作表外的所有工作表
Dim sht As Worksheet
For Each sht In Worksheet
If sht.Name <> ActiveSheet.Name Then
sht.Visible = xlSheetVeryHidden '深度隐藏，不能通過“格式”菜單顯示它
End If
Next
End Sub 6、批量建立工作表
Sub shtAdd()
'一張成績表中儲存不同班級的資料，需要以班級名命名
'根據C列的班級名建立不同的工作表
Dim i As Integer, sht As Worksheet
i = 2
Set sht = Worksheets("成績表")
Do While sht.Cells(i, "C") <> ""
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sht.Cells(i, "C").Value
i = i + 1
Loop
End Sub 7、批量對資料分類
Sub fenLei()
'把成績按班級分到各個工作表中
Dim i As Long, bj As String, rng As Range
i = 2
bj = Cells(i, "C").Value
Do While bj <> ""
'将分表中A列第一個空單元格賦給rng
Set rng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0)
Cells(i, "A").Resize(1, 7).Copy rng '将記錄指派到對應的工作表中
i = i + 1
bj = Cells(i, "C").Value
Loop
End Sub 清除工作表内容
Sub shtClear()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name <> "成績表" Then
sht.Range("A2:G65536").ClearContents
End If
Next
End Sub 8、将工作表儲存為新工作簿
Sub SaveToFile()
'把各個工作表以單獨的工作簿檔案儲存在本工作簿所在的檔案夾下的“班級成績表”檔案夾下
Application.ScreenUpdating = False '關閉螢幕更新
Dim folder As String
folder = ThisWorkbook.Path & "\班級成績表"
'如果檔案夾不存在，則建立檔案夾
If Len(Dir(folder, vbDirectory)) = 0 Then mkdir folder
Dim sht As Worksheet
For Each sht In Worksheets
sht.Copy
ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub 換種寫法：
Sub 自動拆分工作表()
'
' 自動拆分工作表 宏
'
' 快捷鍵: Ctrl+m
'
'把各個工作表以單獨的工作簿檔案儲存在本工作簿所在的檔案夾下的“拆分工作簿”檔案夾下
Application.ScreenUpdating = False '關閉螢幕更新
Dim folder As String
folder = Application.ActiveWorkbook.Path & "\拆分工作簿"
'folder = ThisWorkbook.Path & "\拆分工作簿"
'如果檔案夾不存在，則建立檔案夾
If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
Dim sht As Worksheet
For Each sht In Worksheets
sht.Copy
ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub 9、快速合并多表資料
Sub HeBing()
'把各班級成績表合并到“總成績”工作表中
Rows("2:25536").Clear '删除原有記錄
Dim sht As Worksheet, xrow As Integer, rng As Range
For Each sht In Worksheets '周遊工作簿中所有工作表
If sht.Name <> ActiveSheet.Name Then
Set rng = Range("A65536").End(xlUp).Offset(1, 0) '獲得A列第一個空單元格
xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1 '記錄分表中記錄條數
sht.Range("A2").Resize(xrow, 7).Copy rng '粘貼記錄到彙總表
End If
Next
End Sub 10、彙總同檔案夾下多個工作簿數
Sub HzwWb()
'把目前下各個工作簿的資訊彙總到同檔案夾下的另一個工作簿的同一張工作表裡
Dim r, c As Long
r = 1 '表頭的行數
c = 8 '表頭的列數
Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents '清空彙總表中原資料
Application.ScreenUpdating = False '關閉螢幕更新
Dim FileName As String, wb As Workbook, sht As Worksheet, Erow As Long, fn As String, arr As Variant
FileName = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then '判斷檔案是否是本工作簿
Erow = Range("A1").CurrentRegion.Rows.Count + 1 '取得彙總表中第一條空行行号
fn = ThisWorkbook.Path & "\" & FileName
Set wb = GetObject(fn) '将fn代表的工作簿對象賦給變量
Set sht = wb.Worksheets(1) '彙總的是第一張工作表
'将資料表中的記錄儲存在arr數組裡
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))
'将數組arr中的資料寫入工作表
Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
FileName = Dir '用Dir函數取得其他檔案名，并指派給變量
Loop
Application.ScreenUpdating = True '恢複螢幕更新
End Sub 11、為工作表建立目錄
Sub mkdir()
'為工作簿中所有工作表建立目錄
Rows("2:65536").ClearContents
Dim sht As Worksheet, irow As Integer
irow = 2
For Each sht In Worksheets '周遊工作表
Cells(irow, "A").Value = irow - 1 '寫入序号
'寫入工作表名，并建立超連結
ActiveSheet.Hyperlinks.Add anchor:=Cells(irow, "B"), Address:="", _
SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name
irow = irows + 1 '行号加1
Next
End Sub Sub InputTest()
Cells.ClearContents '清除表中所有資料
Range("A1:A10") = 100
MsgBox "剛才在A1:A10輸入數值100，你能看到結果嗎？"
Range("B1:B10") = 200
MsgBox "剛才在B1:B10輸入數值200，你能看到結果嗎？"
End Sub Sub InputTest()
Cells.ClearContents '清除表中所有資料
Application.ScreenUpdating = False '關閉螢幕更新
Range("A1:A10") = 100
MsgBox "剛才在A1:A10輸入數值100，你能看到結果嗎？"
Range("B1:B10") = 200
MsgBox "剛才在B1:B10輸入數值200，你能看到結果嗎？"
Application.ScreenUpdating = True '恢複螢幕更新
End Sub Sub delSht()
Dim sht As Worksheet
Application.DisplayAlerts = False '不顯示警告資訊
For Each sht In Worksheets
If sht.Name = ActiveSheet.Name Then '判斷sht是不是活動工作表
sht.Delete '删除sht代表的工作表
End If
Next
Application.DisplayAlerts = True '恢複顯示警告資訊
End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Target.Value = Target.Address
End Sub Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Target.Value = Target.Address
Application.EnableEvents = False '禁用事件
Target.Offset(1, 0).Select '選中活動單元格下面的一個單元格
Application.EnableEvents = True '啟用事件
End Sub Sub CountTest()
Dim mycount As Integer, rng As Range
For Each rng In Range("A1:B50")
If rng.Value > 1000 Then mycount = mycount + 1
Next
MsgBox "A1:B50中大于1000的單元格個數為:" & mycount
End Sub Sub CountTest()
Dim mycount As Integer
mycount = Application.WorksheetFunction.CountIf(Range("A1:B50"), ">1000")
MsgBox "A1:B50中大于1000的單元格個數為:" & mycount
End Sub Sub wbMsg()
Range("B2") = ThisWorkbook.Name '傳回目前工作簿名稱 練習 -副本.xlsm
Range("B3") = ThisWorkbook.Path '傳回目前工作簿路徑 C:\Users\ThinkPad\Desktop
Range("B4") = ThisWorkbook.FullName '傳回當期工作簿帶名稱的路徑 C:\Users\ThinkPad\Desktop\練習 - 副本.xlsm
End Sub Sub OpenFile()
Workbooks.Open Filename:="F:\Book1.xls"
End Sub Sub OpenFile()
Workbooks.Open "F:\Book1.xls"
End Sub Sub JhWb()
Workbooks("Book1.xls").Activate '激活工作簿
End Sub Sub SaveWb()
ThisWorkbook.Save '儲存代碼所在的工作簿
End Sub Sub SaveWb()
ThisWorkbook.SaveAs Filename:="D:\test.xls"
End Sub Sub SaveWb()
ThisWorkbook.SaveCopyAs Filename:="D:\test.xls"
End Sub Sub CloseWb()
Workbooks.Close '關閉所有打開的工作簿
End Sub Sub CloseWb()
Workbooks("Book1.xls").Close '關閉Book1.xls
End Sub Sub CloseWb()
Workbooks("Book1.xls").Close savechanges:=True '關閉并儲存Book1.xls
End Sub Sub CloseWb()
Workbooks("Book1.xls").Close True '關閉Book1.xls
End Sub Sub wb()
Workbooks.Add
MsgBox "代碼所在的工作簿為：" & ThisWorkbook.Name & Chr(13) _
& "目前活動工作簿為：" & ActiveWorkbook.Name
ActiveWorkbook.Close savechanges:=False
End Sub Worksheets.Item (1) '引用工作表裡的第一張工作表
Worksheets (1) '引用工作表裡的第一張工作表
Worksheets ("Sheet1") '引用工作簿裡标簽名稱為"Sheet1"的工作表 Sub ShowShtCode()
MsgBox ActiveSheet.CodeName
End Sub Sub shtAdd()
Worksheets.Add after:=Worksheets(1), Count:=3
End Sub Sub shtAdd()
'在最後一個工作表後插入兩張工作表
Worksheets.Add before:=Worksheets(Worksheets.Count), Count:=2
End Sub Sub shtAdd()
Worksheets.Add Before:=Worksheets(1)
ActiveSheet.Name = "工資表"
End Sub Sub shtAdd()
'在第一張工作表前插入一個名稱為“工資表”的工作表
Worksheets.Add(before:=Worksheets(1)).Name = "工資表"
End Sub Sub shtCopy()
'這裡的工作表名稱一定要存在，否則執行會報錯
Worksheets("工資條").Copy '不帶參數 複制工作表，同時建立工作簿用于存放copy來的工作表（未儲存狀态）
Worksheets("工資條").Copy before:=Worksheets("Sheet1") '帶參數 複制工作表，存放在目前工作簿的工作表Sheet1之前
Worksheets("工資條").Copy after:=Worksheets("Sheet1") '帶參數 複制工作表，存放在目前工作簿的工作表Sheet1之後
End Sub Sub shtMove()
Worksheets("工資條").Move '不指定參數，将把工作表移動到新的工作簿中（建立工作簿）
Worksheets("工資條").Move before:=Worksheets("Sheet1") '複制工作表，存放在目前工作簿的工作表Sheet1之前
Worksheets("工資條").Move after:=Worksheets("Sheet1") '複制工作表，存放在目前工作簿的工作表Sheet1之後
End Sub '以下這三行代碼作用一樣，等同于從【格式】菜單中隐藏工作表
Worksheets("工資條").Visible = False
Worksheets("工資條").Visible = xlSheetHidden
Worksheets("工資條").Visible = 0 Worksheets("工資條").Visible = xlSheetVeryHidden
Worksheets("工資條").Visible = 2 Worksheets("工資條").Visible = True
Worksheets("工資條").Visible = xlSheetVisible
Worksheets("工資條").Visible = 1
Worksheets("工資條").Visible = -1 Dim mycount%
mycount=Worksheets.Count Sheets(2).Name
Worksheets(2).Name
Sheets.Count
Worksheets.Count Sub rng()
Range("A1:A10").Value = 200 '在活動工作表的A1:A10輸入值為200
Dim n As String
n = "B1:B10"
Range(n) = 100 '在活動工作表的B1:B10輸入值為100
End Sub Sub rng()
Range("date").Value = 200
End Sub Sub rng()
Range("A1:A10,A4:E6,C3:D9").Value = 200
End Sub Sub rng()
Range("A1:B10 A4:D9").Value = 200
End Sub Sub shtCells()
ActiveSheet.Cells(3, 4).Value = 20 '在第3行，第4列香蕉的單元格輸入20
ActiveSheet.Cells(3, "D").Value = 30 '在第3行，第D列相交的單元格輸入30
Range("B3:F9").Cells(2, 3) = 40 '在區域“B3:F9”區域中的第2行，第3列相交的單元格，即D4
ActiveSheet.Cells(2).Value = 50 '在活動工作表的第二個單元格輸入50,這裡使用的數字2是單元格序号，序号是按照單元格區域内由左向右遞增
'選中活動工作表的A1:E10
Range(Cells(1, 1), Cells(10, 5)).Select
'以下兩個語句等價
Range("A1", "E10").Select
Range(Range("A1"), Range("E10")).Select
End Sub Sub shtCells()
ActiveSheet.Cells.Select '選中活動工作表的所有單元格
Range("B3:E9").Select '選中活動工作表中B3:E9單元格區域
End Sub Sub shtCells()
[A1] = 10
[A1:B10] = 20
[B3:D10 A4:G8] = 100 '公共交叉區域，如果兩個區域參數沒有逗号，表示一個參數，而參數表示的區域沒有交集的話會報錯
[A1:A10,C1:C10,E1:E10] = 200 '合并區域
[area] = 300 '名稱are代表單元格，即單元格名稱為area
End Sub ActiveSheet.Rows '選中活動工作表的所有行
ActiveSheet.Rows(3).Select '選中活動工作表的第3行
ActiveSheet.Rows("3:3").Select '選中活動工作表的第3行
ActiveSheet.Rows("3:5").Select '選中活動工作表的第3行到第5行
Rows("3:10").Rows("1:1").Select '選中第3行到第10行區域内的第一行 ActiveSheet.Columns '選中活動工作表的所有列
ActiveSheet.Columns (6) '選中活動工作表中的第6列
ActiveSheet.Columns ("F:G") '選中活動工作表中的F至G列
Columns("B:G").Columns("B:B").Select '選中B:G區域中的第2列 Sub rngUnion()
Application.Union(Range("A1:A10"), Range("D1:D5")).Select '入參至少為2個區域，至多30個區域，區域之間用逗号分隔
Union(Range("A1:A10"), Range("D1:D5")).Select 'application可以省略不寫
End Sub Sub rngOffset()
Range("A1").Offset(2, 3).Value = 500 '基于“A1”單元格，向下移動2行，向右移動3列
Range("C5:D6").Offset(-3, 0).Select '在“C5：D6”區域的基礎上，向上移動3行，列方向參數為0，不移動。
End Sub Sub rngResize()
'将B2單元格擴大為B2:E6
Range("B2").Resize(5, 4).Select
'将B2：E6單元格縮小為B2：B3，新區域以B2單元格為最左上角單元格
Range("B2:E6").Resize(2, 1).Select
'上句等同于
Range("B2:E6").Cells(1).Resize(2, 1).Select
End Sub Sub rngUsed()
ActiveSheet.UsedRange.Select
End Sub Sub rngUsed()
Range("D3").CurrentRegion.Select
End Sub Sub rngEnd()
Range("E5").End(xlUp).Select
End Sub Sub rngEnd()
'取第一個單元格，如果非空則向下移動一個單元格，否則不移動。對新單元格進行指派
Dim c As Range
Set c = ActiveSheet.Range("A65536").End(xlUp)
If c.Value <> "" Then
Set c = c.Offset(1, 0)
End If
c.Value = "張青"
End Sub
Sub rngUsed()
'取使用區域内行數增加1，對該行的A列進行指派
Dim xrow As Long
xrow = ActiveSheet.UsedRange.Rows.Count + 1
Cells(xrow, "A").Value = "張青"
End Sub
Sub rngCurr()
'取目前區域内行數增加1，對該行的A列進行指派
Dim xrow As Long
xrow = Range("A1").CurrentRegion.Rows.Count + 1
Cells(xrow, "A").Value = "張青"
End Sub Range("A1:B2").Value = "abc"
Range("A1:B2") = "abc" 'Value是Range的預設屬性，在給區域指派時可以省略。 Range("B4:F10").Count '統計單元格數量
ActiveSheet.UsedRange.Rows.Count '統計活動單元格的行數
ActiveSheet.UsedRange.Columns.Count '統計活動單元格的列數 ActiveSheet.Range("A1:B10").Select
ActiveSheet.Range("A1:B10").Activate Range("B2:B15").Clear '清除B2:B15單元格所有内容（包括批注、内容、注釋、格式等）
Range("B2:B15").ClearComments '清除B2:B15單元格批注
Range("B2:B15").ClearContents '清除B2:B15單元格内容
Range("B2:B15").ClearFormats '清除B2:B15單元格格式 Sub Macro1()
Range("A1").Select
Selection.Copy
Range("C1").Select
ActiveSheet.Paste
End Sub Sub Macro1()
Range("A1").Copy Range("C1") 'A1是源單元格，C1是目标單元格
End Sub Sub Macro1()
Range("A1").Copy Destination:=Range("C1") 'A1是源單元格，C1是目标單元格,Destination是目标
End Sub Sub Macro1()
Range("A1").CurrentRegion.Copy Range("C1") 'A1是源單元格，C1是目标單元格,Destination是目标
End Sub Sub rngCopyValue_1()
Range("A1:A10").Copy
Range("F1:F10").PasteSpecial Paste:=xlPasteValues '僅粘貼數值
End Sub
Sub rngCopyValue_2()
Range("A1:A10").Value = Range("F1:F10").Value
End Sub Sub rngCut()
Range("A1:A5").Cut Destination:=Range("G1") '把A1:A5剪切到G1:G5，這裡G1表示以G1為左上角第一個單元格的區域
Range("F6:F10").Cut Range("G6") '把F1:F10剪切到G6:K10，參數Destination可以省略
End Sub Range("B5").Delete Shift:=xlToLeft '删除B5單元格，删除後右側單元格左移
Range("B5").Delete Shift:=xlUp '删除B5單元格，删除後下方單元格上移
Range("B5").EntireRow.Delete '删除B5單元格所在的行
Range("B5").EntireColumn.Delete '删除B5單元格所在的列 'Add建立名稱的方法，RefersToR1C1表示使用R1C1引用樣式
ActiveWorkbook.Names.Add Name = "date", RefersToR1C1:="Sheet1!R5C[-2]" 'Add建立名稱的方法，RefersToR1C1表示使用A1引用樣式,$表示相對絕對引用，将把活動單元格當做A1單元格
ActiveWorkbook.Names.Add Name = "date", RefersTo:="Sheet1$B$4" Range("A1:C10") = "date" ActiveWorkbook.Names("date").Name = "姓名"
ActiveWorkbook.Names("姓名").Name = "張三" Sub UseName()
Dim i, mx As Integer
mx = ActiveWorkbook.Names.Count '統計一共有多少個單元格
For i = 1 To mx
activateworkbook.Names(i).Visible = False '隐藏名稱
Next
End Sub Range("B5").AddComment Text:="我用VBA建立的批注" Sub wbComment()
Range("B5").AddComment Text:="我用VBA建立的批注"
If Range("B5").Comment Is Nothing Then '判斷是否存在Comment對象
MsgBox "B5單元格中沒有批注"
Else
MsgBox "B5單元格中已有批注"
End If
End Sub Sub operComment()
Range("B5").AddComment Text:="我用VBA建立的批注" '建立批注
Range("B5").Comment.Visible = False '隐藏B5單元格批注
Range("B5").Comment.Delete '删除B5單元格批注
End Sub Sub FontSet()
With Range("A1:L1").Font
.Name = "宋體" '設定字型為宋體
.Size = 12 '設定字号為12号
.Color = RGB(255, 0, 0) '設定字型顔色為紅色
.Bold = True '設定字型加粗
.Italic = True '設定字型傾斜顯示
.Underline = xlUnderlineStyleDouble 'feud文字添加雙下劃線
End With
End Sub Sub InteriorSet()
Range("A1:L1").Interior.Color = RGB(255, 255, 0) '增加黃色底紋
End Sub Sub InteriorSet()
With Range("A1").CurrentRegion.Borders
.LineStyle = xlContinuous '設定單線邊框
.Color = RGB(0, 0, 255) '設定邊框顔色
.Weight = xlHairline '設定邊框線條樣式
End With
End Sub Sub wbAdd()
'程式建立“員工花名冊”工作簿，儲存在本工作簿所在的檔案夾中
Dim wb As Workbook, sht As Worksheet '定義一個Workbook對象和一個Worksheet對象
Set wb = Workbooks.Add '建立一個工作簿
Set sht = wb.Worksheets(1)
With sht
.Name = "花名冊" '修改第一張工作表的标簽名稱
.Range("A1:F1") = Array("序号", "姓名", "性别", "出生年月", "參加工作時間", "備注") '設定表頭
End With
wb.SaveAs ThisWorkbook.Path & "\員工花名冊.xls" '儲存建立的工作表到本工作簿所在的檔案夾中
ActiveWorkbook.Close '關閉建立的工作簿
End Sub '判斷"成績表.xls"工作簿是否打開
Sub isWbOpen()
Dim i As Integer
For i = 1 To Workbooks.Count
If Workbooks(i).Name = "成績表.xls" Then
MsgBox "檔案已打開"
Exit Sub '如果找到該檔案，退出過程
End If
Next
MsgBox "檔案沒有打開"
End Sub '判斷打開的工作表中是否含“一年級”，有則移動到第一個位置，否則在第一個位置建立
Sub isShtOpen()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name = "一年級" Then
sht.Move before:=Worksheets(1)
'MsgBox "已經打開"
Exit Sub
End If
Next
Worksheets.Add(before:=Worksheets(1)).Name = "一年級"
End Sub '判斷打開的工作表中是否含“一年級”，有則移動到第一個位置，否則在第一個位置建立 Sub isShtOpen()
On Error Resume Next
If Worksheets("一年級") Is Nothing Then
Worksheets.Add(before:=Worksheets(1)).Name = "一年級"
Else
Worksheet("一年級").Move before:=Worksheets(1)
'MsgBox "已經打開"
End If
End Sub Sub isExistWb()
'判斷本工作簿所在的檔案夾中是否存在“員工花名冊.xls”
Dim fil As String
fil = ThisWorkbook.Path & "\員工花名冊.xls"
If Len(Dir(fil)) > 0 Then
MsgBox "工作簿已經存在"
Else
MsgBox "工作簿不存在"
End If
End Sub Sub WbInput()
'在本工作簿所在的檔案夾下“員工花名冊”裡添加一條記錄
Dim wb As String, xrow As Integer, arr
wb = ThisWorkbook.Path & "\員工花名冊.xls"
Workbooks.Open (wb)
With ActiveWorkbook.Worksheets(1)
xrow = .Range("A1").CurrentRegion.Rows.Count + 1
arr = Array(xrow - 1, "張嬌", "女", "#7/8/1987#", "#9/1/2010#", "10年新招")
.Cells(xrow, 1).Resize(1, 6) = arr
End With
ActiveWorkbook.Close savechanges:=True
End Sub Sub ShtVisible()
'隐藏活動工作表外的所有工作表
Dim sht As Worksheet
For Each sht In Worksheet
If sht.Name <> ActiveSheet.Name Then
sht.Visible = xlSheetVeryHidden '深度隐藏，不能通過“格式”菜單顯示它
End If
Next
End Sub Sub shtAdd()
'一張成績表中儲存不同班級的資料，需要以班級名命名
'根據C列的班級名建立不同的工作表
Dim i As Integer, sht As Worksheet
i = 2
Set sht = Worksheets("成績表")
Do While sht.Cells(i, "C") <> ""
Worksheets.Add after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = sht.Cells(i, "C").Value
i = i + 1
Loop
End Sub Sub fenLei()
'把成績按班級分到各個工作表中
Dim i As Long, bj As String, rng As Range
i = 2
bj = Cells(i, "C").Value
Do While bj <> ""
'将分表中A列第一個空單元格賦給rng
Set rng = Worksheets(bj).Range("A65536").End(xlUp).Offset(1, 0)
Cells(i, "A").Resize(1, 7).Copy rng '将記錄指派到對應的工作表中
i = i + 1
bj = Cells(i, "C").Value
Loop
End Sub Sub shtClear()
Dim sht As Worksheet
For Each sht In Worksheets
If sht.Name <> "成績表" Then
sht.Range("A2:G65536").ClearContents
End If
Next
End Sub Sub SaveToFile()
'把各個工作表以單獨的工作簿檔案儲存在本工作簿所在的檔案夾下的“班級成績表”檔案夾下
Application.ScreenUpdating = False '關閉螢幕更新
Dim folder As String
folder = ThisWorkbook.Path & "\班級成績表"
'如果檔案夾不存在，則建立檔案夾
If Len(Dir(folder, vbDirectory)) = 0 Then mkdir folder
Dim sht As Worksheet
For Each sht In Worksheets
sht.Copy
ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub Sub 自動拆分工作表()
'
' 自動拆分工作表 宏
'
' 快捷鍵: Ctrl+m
'
'把各個工作表以單獨的工作簿檔案儲存在本工作簿所在的檔案夾下的“拆分工作簿”檔案夾下
Application.ScreenUpdating = False '關閉螢幕更新
Dim folder As String
folder = Application.ActiveWorkbook.Path & "\拆分工作簿"
'folder = ThisWorkbook.Path & "\拆分工作簿"
'如果檔案夾不存在，則建立檔案夾
If Len(Dir(folder, vbDirectory)) = 0 Then MkDir folder
Dim sht As Worksheet
For Each sht In Worksheets
sht.Copy
ActiveWorkbook.SaveAs folder & "\" & sht.Name & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub Sub HeBing()
'把各班級成績表合并到“總成績”工作表中
Rows("2:25536").Clear '删除原有記錄
Dim sht As Worksheet, xrow As Integer, rng As Range
For Each sht In Worksheets '周遊工作簿中所有工作表
If sht.Name <> ActiveSheet.Name Then
Set rng = Range("A65536").End(xlUp).Offset(1, 0) '獲得A列第一個空單元格
xrow = sht.Range("A1").CurrentRegion.Rows.Count - 1 '記錄分表中記錄條數
sht.Range("A2").Resize(xrow, 7).Copy rng '粘貼記錄到彙總表
End If
Next
End Sub Sub HzwWb()
'把目前下各個工作簿的資訊彙總到同檔案夾下的另一個工作簿的同一張工作表裡
Dim r, c As Long
r = 1 '表頭的行數
c = 8 '表頭的列數
Range(Cells(r + 1, "A"), Cells(65536, c)).ClearContents '清空彙總表中原資料
Application.ScreenUpdating = False '關閉螢幕更新
Dim FileName As String, wb As Workbook, sht As Worksheet, Erow As Long, fn As String, arr As Variant
FileName = Dir(ThisWorkbook.Path & "\" & "*.xlsx")
Do While FileName <> ""
If FileName <> ThisWorkbook.Name Then '判斷檔案是否是本工作簿
Erow = Range("A1").CurrentRegion.Rows.Count + 1 '取得彙總表中第一條空行行号
fn = ThisWorkbook.Path & "\" & FileName
Set wb = GetObject(fn) '将fn代表的工作簿對象賦給變量
Set sht = wb.Worksheets(1) '彙總的是第一張工作表
'将資料表中的記錄儲存在arr數組裡
arr = sht.Range(sht.Cells(r + 1, "A"), sht.Cells(65536, "B").End(xlUp).Offset(0, 8))
'将數組arr中的資料寫入工作表
Cells(Erow, "A").Resize(UBound(arr, 1), UBound(arr, 2)) = arr
wb.Close False
End If
FileName = Dir '用Dir函數取得其他檔案名，并指派給變量
Loop
Application.ScreenUpdating = True '恢複螢幕更新
End Sub Sub mkdir()
'為工作簿中所有工作表建立目錄
Rows("2:65536").ClearContents
Dim sht As Worksheet, irow As Integer
irow = 2
For Each sht In Worksheets '周遊工作表
Cells(irow, "A").Value = irow - 1 '寫入序号
'寫入工作表名，并建立超連結
ActiveSheet.Hyperlinks.Add anchor:=Cells(irow, "B"), Address:="", _
SubAddress:="'" & sht.Name & "'!A1", TextToDisplay:=sht.Name
irow = irows + 1 '行号加1
Next
End Sub