「VBA」學習筆記

06-30

1、常用單句

常用調試工具

Debug.Print；MsgBox；立即窗口，本地窗口，監視窗口

常用開頭與結尾

Dim tim As Date: tim = Timer "記錄當前時間(0到開始到現在的時間,單位為秒)

Application.ScreenUpdating = False "關閉屏幕更新

Application.DisplayAlerts = False "關閉提示

Call 調用程序

MsgBox Format(Timer - tim, "程序執行時間為：0.00秒"), 64, "時間統計" "報告代碼的執行時長

Application.ScreenUpdating = True "恢復屏幕更新

Application.DisplayAlerts = True "恢復提示

清除內容和添加邊框

.ClearContents "刪除當前區域值

.Borders.LineStyle = 0 "刪除當前區域邊框

.Borders.LineStyle = 1 "當前區域添加邊框

Error語句

On Error Resume Next "當程序出錯時繼續執行下一句

Err.Clear"清除錯誤值

常用變數類型及簡碼

Dim Ows As Worksheet, Orng As Range ,Dic1 As Object；Private ；Public

integer % 短整型-32,768 到 32,767

long &長整型-2,147,483,648 ---- 2,147,483,648貳拾億

single !單精度浮點型

string $ 字元型

字典常用

Set Dic1 = CreateObject("scripting.dictionary") "創建字典對象，並賦值給Dic1

Dic1.Item(Arr (i, 2)) = Dic1.Item(Arr (i, 2)) + Arr (i, 1) "匯總求和

字典對象的方法有6個：Add方法、Keys方法、Items方法、Exists方法、Remove方法、RemoveAll方法。

Exists方法：object.Exists(key)

Remove方法：object.Remove(key )

RemoveAll方法：object.RemoveAll

CStr(expression) - 轉換為String型"字典中的key屬性盡量用String型

移出字典中特定的項目

For Each K1 In Dic2.KEYs "循環字典的KEYS

If Dic2.Item(K1) >= 0 Then Dic2.Remove (K1) " 移出item大於或等於零的項目

For Each K1 In Arr臨2 "循環數組中的值

If Dic2.Exists(K1) = True Then Dic2.Remove (K1) "如果字典中存在，移出字典

數組常用

Option Base 1"數組下標為"1"

Cr= Cr+1；ReDim Preserve Arr2(1 To 2, 1 To Cr)"最後一維可以變化，不清除原數組的值

Arr1 = [{"倉庫收發存匯總報表","庫存原表";"材料在制明細報表","在制原表"}]"二維數組賦值

UBound(Arr1, 1)"數組上標

Join - 連接數組成字元串。

Split - 拆分字元串成數組。

常用判斷條件

If InStr("-0-J-", "-" & Left(Arr原(Item, 1), 1) & "-") > 0 Then "取成品碼

Set Orng = Ows.UsedRange.Find(關鍵字) "返回Range對象

If Not Orng Is Nothing Then"如果不是空值

單元格引用

Range("A1")；Range("A1:F10000")；Range("2:2")；Range("D:d")

Rows(2)；Rows("2") ；Rows("2:2")；

Columns(2) ；Columns("B") ；Columns("B:B") ；

Cells(5,4)；Cells(12, "ZZ")；Cells("12", "ZZ")；Range("B2:G10").Cells(5)；

[a1] ；[B$10] ；也表示偏移，通常不用這個功能。

[D2:F500] ——表示引用D2:F500區域，包括1497個單元格

[D2,F2] ——表示引用D2和F2兩個單元格

[D2:D3,F2:G10,Z100] ——表示引用D2:D3和F2:G10、Z100三個區域，包括21個單元格

.Offset(0, 2).Resize(Dic1.Count, 1) = Application.WorksheetFunction.Transpose(Dic1.items) "寫入數量

arr = Sheets("原始數據").[a1].CurrentRegion"A1單元格+Ctrl+A

Resize(.UsedRange.Rows.Count, 4).ClearContents "清除前期內容

.Cells(.Rows.Count, 18).End(xlUp).Row"最後一行行數

.Sheets.Add(, .Sheets(.Sheets.Count)).Name = Arr1(j, 2) "在最後一個工作表後新建工作表

2、常用案例

提取文件

思路：用Application.GetOpenFilename把工作簿讀入Filename數組中，逐個工作簿循環，逐個工作表循環，逐個關鍵字循環。用find判斷查找關鍵字，確定需要的文件。提取文件後在Old_Name的工作簿中建工作表，把查找到的工作表複製過去。

Sub 提取文件()

On Error Resume Next "當程序出錯時繼續執行下一句

Dim Arr1(), i %, j %, Ows As Worksheet, Orng As Range, Arr1(),Filename, _

Old_Name$, New_Name$ "聲明變數，由於GetOpenFilename的返回值是數組，變數只能用變體型

Arr1 = [{"倉庫收發存匯總報表","庫存原表";"材料在制明細報表","在制原表"}]

Old_Name = ActiveWorkbook.Name "獲取當前工作簿的名稱

"創建一個打開文件的對話框，允許多選，然後將返回值賦予變數FileName

Filename = Application.GetOpenFilename("文本文件,*.txt;*.xls?", , "請選擇文本文件", , True)

For i = 1 To UBound(Filename) "遍曆數組,Ubound函數用於計算數組中的數據個數

If Err.Number> 0 Then Exit Sub "如果有錯誤，那麼結束過程(單擊了"取消"鍵時才會有錯誤)

Workbooks.Open Filename(i) "逐一報告數組中的文件名稱

New_Name = ActiveWorkbook.Name

For j = 1 To UBound(Arr1, 1)

For Each Ows In Workbooks(New_Name).Worksheets

With Ows.UsedRange

Set Orng = .Find(Arr1(j, 1)) "返回Range對象

If Not Orng Is Nothing Then

With Workbooks(Old_Name)

.Sheets(Arr1(j, 2)).Delete: Err.Clear "刪除工作表"清除錯誤值，

"避免"i=2時Err.Number> 0直接退出程序

.Sheets.Add(, .Sheets(.Sheets.Count)).Name = Arr1(j, 2)

"在最後一個工作表後新建工作表

End With

.Copy Workbooks(Old_Name).Sheets(Arr1(j, 2)).Cells(1) "複製工作表

Exit For

End If

End With

Next Ows

Next j

ActiveWorkbook.Close , False "關閉工作簿

Next i

End Sub

保存文件Sheets.Copy

Sub 保存工作報表()

思路：用Application.FileDialog(msoFileDialogFolderPicker)選擇路徑，用Path記錄路徑

Dim ShtDate,Path$ "聲明變數

ActiveWorkbook.Save

ShtDate = Format(Date, "yyyy-mm-dd") "將今日日期格式化為"yyyy-mm-dd"格式

With Application.FileDialog(msoFileDialogFolderPicker) "彈出對話框讓用戶選擇路徑

If .Show = -1 Then "如果選擇了文件夾則

Path = .SelectedItems(1) &IIf(Right(.SelectedItems(1), 1) = "", "", "")"記錄路徑

Else

Exit Sub

End If

End With

Sheets.Copy "複製所有工作表

Sheets("功能區").Delete "刪除帶控制項的工作表

ActiveWorkbook.SaveAs Path & "M1資源結構分析表" &ShtDate, xlWorkbookDefault

ActiveWorkbook.Close , False "關閉工作簿

End Sub

常用函數

注意很多excel函數的參數是range，而不是arry,

Sumifs用法

思路:定義range對象，通過Application.WorksheetFunction.引用函數SumIfs

Set Orng編碼列 = .Range("H5:H" & R原)

Set Orng狀態列 = .Range("E5:E" & R原)

Set Orng完工數 = .Range("N5:N" & R原)

With Sheets("完工取數")

For i = 0 To UBound(Arr編碼)

For j = 1 To UBound(Arr在制, 2)

Arr在制(i, j) = Application.WorksheetFunction.SumIfs(.Range("W5:W" & R原).Offset(, j - 1), Orng編碼列, Arr編碼(i), Orng狀態列, "已關閉") _

+ Application.WorksheetFunction.SumIfs(.Range("W5:W" & R原).Offset(, j - 1), Orng編碼列, Arr編碼(i), Orng狀態列, "完成")

End With

其他常用函數

Abs絕對值函數

字典Exists判斷匯總1

Set Dic1 = CreateObject("scripting.dictionary") "創建字典對象，並賦值給Dic1

Set Dic2 = CreateObject("scripting.dictionary") "創建字典對象，並賦值給Dic2

Arr1 = .Range("A2").Resize(.Cells(.Rows.Count, 1).End(xlUp).Row - 1, 4).Value "將所有數據寫入數組

For i = 1 To UBound(Arr1, 1) "遍曆數據

"取商品名稱與價格

If Dic1.Exists(Arr1(i, 1) & Arr1(i, 2)) = False Then"如果字典中沒有key則

j = j + 1

ReDim Preserve Arr2(1 To 2, 1 To j)"數組增加一列，最終數據增加一行

Arr2(1, j) = Arr1(i, 1): Arr2(2, j) = Arr1(i, 2)

End If

Dic1.Item(Arr1(i, 1) & Arr1(i, 2)) = Dic1.Item(Arr1(i, 1) & Arr1(i, 2)) + Arr1(i, 3) "取數量

Dic2.Item(Arr1(i, 1) & Arr1(i, 2)) = Dic2.Item(Arr1(i, 1) & Arr1(i, 2)) + Arr1(i, 4) "取金額

With .Range("G2")

.Resize(UBound(Arr2, 2), 2) = Application.WorksheetFunction.Transpose(Arr2) "寫入商品名稱與單價

.Offset(0, 2).Resize(Dic1.Count, 1) = Application.WorksheetFunction.Transpose(Dic1.items) "寫入數量

.Offset(0, 3).Resize(Dic2.Count, 1) = Application.WorksheetFunction.Transpose(Dic2.items) "寫入金額

End With

3、非常用案例

使用期限設置

思路：打開工作簿時給"期限"和當前日期賦值，並提醒報表使用者，關閉工作簿時（Kill .FullName）刪除。注意：刪除後數據無法恢復。

Private a$, 期限$ "定義共用變臉

Sub Auto_open() "打開工作簿時執行

期限 = "2018年2月27日"

a = Format(Date, "yyyy年m月d日") "當前年月日

If a >期限 Then MsgBox "超過使用期限；" &Chr(13) _

& "工作簿將自動刪除；" &Chr(13) _

& "請複製要保存的數據"

End Sub

"Sub Auto_close() "打開工作簿時執行

If a >期限 Then

With ThisWorkbook "引用ThisWorkbook

.Saved = True "標識為已保存狀態

.ChangeFileAccess Mode:=xlReadOnly "設為只讀模式

Kill .FullName "刪除ThisWorkbook

.Close "關閉ThisWorkbook

End With

End If

End Sub

建立超鏈接工作表目錄Hyperlinks

Sub 建立工作表目錄()

Dim Sht As Worksheet, i As Integer "聲明一個對象變數一個Integer變數

For Each Sht In Sheets "遍歷所有表

"如果sht的名字等於"工作表目錄"，那麼跳轉至標籤Mulu處

If Sht.Name = "工作表目錄" Then GoToMulu

Worksheets.Add Worksheets(1) "新建一個工作表，將它放在第一個工作之前

ActiveSheet.Name = "工作表目錄" "將活動工作表命名為"工作表目錄"

Mulu: "設置一個名為"Mulu"的標籤

Worksheets("工作表目錄").Range("A:B").Clear "清除A、B兩列的值

For Each Sht In Worksheets "遍歷所有工作表

If Sht.Name<> "工作表目錄" Then "如果sht的名稱不等於"工作表目錄"

i = i + 1 "累加計數器

Worksheets("工作表目錄").Cells(i, 1).Value = i "在A列輸入編號

"在B列創建超級鏈接,從而允許單擊單元格時進入相應的工作表

Worksheets("工作表目錄").Hyperlinks.Add Anchor:=Worksheets("工作表目錄").Cells(i, 2), Address:="", SubAddress:=""" &Sht.Name& ""!A1", TextToDisplay:=Sht.Name, ScreenTip:="單擊打開：" &Sht.Name

End If

End Sub

Rem Hyperlinks.Add方法用於創建超級鏈接，其語法如下：

Rem Hyperlinks.Add(Anchor, Address, SubAddress, ScreenTip, TextToDisplay)

Rem 各參數的含義如下:

Rem 名稱必選/可選數據類型說明

Rem Anchor 必選 Object 超鏈接的位置。可為 Range 或 Shape 對象。

Rem Address 必選 String 超鏈接的地址。

Rem SubAddress可選 Variant 超鏈接的子地址。

Rem ScreenTip 可選 Variant 當滑鼠指針停留在超鏈接上時所顯示的屏幕提示。

Rem TextToDisplay可選 Variant 要顯示的超鏈接的文本。

Inputbox用法

注意：inputbox只能調用本工作簿中的區域，需增加其他語句配合調用其他工作簿。

粘貼時跳過隱藏行

思路：用inputbox選擇區域，然後Rng選取可見區域，循環可見區域單元格，逐一賦值

Sub 粘貼時跳過隱藏行()

On Error Resume Next "當程序出錯時繼續執行下一句

Dim Rng As Range, i%, C As Range, 複製 As Range, 粘貼 As Range, Arr()

Set 複製 = Application.InputBox(prompt:="請選擇要複製的區域", Type:=8)

If 複製 Is Nothing Then Exit Sub "如果沒有賦值，退出程序

Set 粘貼 = Application.InputBox(prompt:="請選擇要粘貼的區域", Type:=8)

If 粘貼 Is Nothing Then Exit Sub "如果沒有賦值，退出程序

Set Rng = 粘貼.SpecialCells(xlCellTypeVisible) "將選擇區域可見的部分賦值給rng

Arr = 複製.Value "將複製的數據賦值給數組

For Each C In Rng "逐一選取可見的單元格

i = i + 1

C.Value = Arr(i, 1) "將複製的內容逐一粘貼到目標區域

If i = UBound(Arr, 1) Then Exit For "如果複製的值結束，退出循環。（本句避免複製的區域低於粘貼區域時出錯）

End Sub