VBA常用代碼模版

• Tp0??—零零散散小功能（持續更新）
• Tp1??—輸出活動頁面篩選后的行數
• Tp2??—創建數組存放數據
• • Tp2-1 靜態數組
  • Tp2-2 動態數組
• Tp3?? 創建字典存放數據
• Tp4?? 優化代碼運行速度
• Tp5?? 輕松實現工作簿加密
• Tp6?? 通過對話框選擇文件-1
• Tp7?? 通過對話框選擇文件-2
• Tp8?? 從目錄頁自動跳轉至明細頁
• Tp9?? 選擇區域自動設置或取消值

Tp0??—零零散散小功能（持續更新）

• 剪切列
• 替換字符
• 取消復制剪切狀態
• 浮點數向上取值
• 區域添加邊框
• 區域設置顏色
• 調整列寬、行高
• 待更新

' 小功能集合 Sub Demos()' 剪切一列到指定列With ThisWorkbook.Sheets(2) .[AI:AI].Cut .[AE:AE].Select Selection.Insert Shift:=xlToRightEnd With' 替換字符，將（空白）替換為空With worksheet.[C:C].Replace "(空白)", ""End With' 取消復制剪貼狀態Application.CutCopyMode = False' 將帶有小數的數據向上取整NewData = Application.WorksheetFunction.RoundUp(Datas, 0)' 單元格區域添加邊框.Range("A4:N" & .Range("A9999").End(xlUp).Row).Borders.LineStyle = xlContinuous' -------------單元格標色-------------' 指定區域標色With Range("C2:G9").Interior.ColorIndex = 0 ' 無填充顏色.Interior.ColorIndex = 3 ' 紅色.Interior.ColorIndex = 5 ' 藍色 End With' 實現自動調整行高、列寬Rows("1:5").EntireRow.AutoFit ' 調整1至5行行高Columns("A:AA").EntireColumn.AutoFit ' 調整A至AA列列寬' 設置行高、列寬為固定值Rows("1:5").RowHeight = 15 ' 設置1至5行行高為15Columns("A:AA").ColumnWidth = 15 ' 設置A至AA列列寬為15End Sub

顏色索引-Range屬性

Tp1??—輸出活動頁面篩選后的行數

' 獲取活動頁面篩選后的行數 Sub RowCntAfterFilter()Dim rngCell As RangeDim lngRowCnt As LongFor Each rngCell In [a1].CurrentRegion.SpecialCells(xlCellTypeVisible).AreaslngRowCnt = lngRowCnt + rngCell.Rows.CountNext rngCellrows_count = lngRowCnt - 1 '可視區行數MsgBox "篩選后數據行數為：" & rows_count Set rngCell = NothingEnd Sub

Tp2??—創建數組存放數據

通過數組可以快速對數據進行處理
前提：表格數據須規范，不考慮合并單元格
一維數組：數字(1,2,3,4)，字符串(a,b,c,d)
二維數組：((1,1),(1,2),(1,3),(2,1),(2,2),(2,3)) 表格結構、行列轉置、計算、遍歷、統計…
多維數組：不是很熟悉，不敢亂說（￣□￣｜｜）
簡單介紹靜態數組、動態數組的使用

Tp2-1 靜態數組

Sub SetArray()’ 靜態數組可直接通過 變量名=數組（）的方式設置array_number = Array(1,2,3,4,5)array_string = Array("張三","李四","王五","Sugar","Smile")' 可遍歷，參數：count，Index 取值：data = array_data(1)' 賦值.[A1:A5] = array_number .[B1:B5] = array_string'存放單元格區域數據到數組（二維數組的快捷應用）Dim arr As Variant '定義一個Variant類型的變量，名稱為arrarr = Range("A1:C3").Value '將A1:C3中保存的數據存儲到數組arr里Range("E1:G3").Value = arr '將數組ar寫入E1:G3單元格區域End Sub

Tp2-2 動態數組

Sub VimArray()'自定義動態數組長度n，上界為0Dim n As Integern = 0Dim SupArr() As String ' 定義動態數組存放供應商名稱With ActiveSheet For i = 2 To .[A1048576].End(xlUp).RowReDim Preserve SupArr(n) ' 給動態數組重定義一個實際的大小n = n + 1SupArr(n - 1) = .Cells(i, 3).Value ' 存到動態數組里去Next iEnd WithEnd Sub

Tp3?? 創建字典存放數據

通過字典可以快速對數據進行處理
存放鍵值對關系，key具有唯一性，
參數：count，keys，values，Item
需要創建字典對象后使用

'與Excel單元格結合，創建字典存放數據 Sub RngDict()Dim DicManForm As ObjectSet DicManForm = CreateObject("Scripting.Dictionary")key_MaxRow = ActiveSheet.[A66666].End(xlUp).Row '活動工作表A列的最后一行的行數'對A列進行遍歷For key_Row = 2 To key_MaxRow'取A列不重復的值作為字典的key，索引值唯一KeyXX = ActiveSheet.Cells(key_Row, 1).Value'導入條件：不為空，不重復If KeyXX <> "" And DicManForm.Exists(KeyXX) = False ThenDicManForm.Add KeyXX, key_RowEnd IfNext'通過key值，重設對應的value，key不存在時會報錯DicManForm(key) = valueSet DicManForm = NothingEnd Sub

Tp4?? 優化代碼運行速度

為了加快代碼的執行速度，最簡單的方式，將代碼的執行過程設置為不顯示，可以在代碼執行時，臨時關閉后續設置：自動重算、自動刷新、彈窗警告
溫馨提示：以下代碼需要成對出現，設置False后，末尾改回True

Sub AppSetting()’ 程序開始With Application.ScreenUpdating = False ' 關閉屏幕刷新.EnableEvents = False ' 關閉事件觸發.DisplayAlerts = False ' 關閉彈窗提示End With' Your Code ' 調用程序運行的主體代碼’程序末尾With Application.ScreenUpdating = True ' 恢復屏幕刷新.EnableEvents = True ' 恢復事件觸發.DisplayAlerts = True ' 恢復彈窗提示End WithEnd Sub

好久不見、更新繼續

Tp5?? 輕松實現工作簿加密

Sub 解除全部工作表保護()Dim n As IntegerFor n = 1 To Sheets.CountSheets(n).UnprotectNext n End SubSub 為指定工作表加指定密碼保護表()Sheet10.Protect Password:="123" End SubSub 在有密碼的工作表執行代碼()Sheets("1").Unprotect Password:=123 '假定表名為“1”，密碼為“123” 打開工作表Range("C:C").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True '隱藏C列空值行Sheets("1").Protect Password:=123 '重新用密碼保護工作表 End Sub

Tp6?? 通過對話框選擇文件-1

' 設置選擇文件的彈出窗口，自主選擇文件 Sub FilePicker()Open_Path = ThisWorkbook.Sheets("操作界面").[B4]'新建一個對話框對象Set FileDialogObject = Application.FileDialog(msoFileDialogFilePicker)'配置對話框With FileDialogObject.Title = "請選擇目標文件所在的文件夾："'添加判斷，改變對話框默認打開的路徑'默認打開上次的文件路徑If Open_Path = "" Then.InitialFileName = "C:\"Else.InitialFileName = Open_PathEnd IfEnd With'顯示對話框FileDialogObject.Show'獲取選擇對話框選擇的文件Set paths = FileDialogObject.SelectedItemsWith Sheets("操作界面").[I:I].Clearfile_ = paths.Item(1) '包含絕對路徑的文件名.[B4].Value = paths.Parent.InitialFileName '當前文件所在目錄.[B6].Value = Right(file_, Len(file_) - Len(paths.Parent.InitialFileName)) '獲取文件'選擇多個文件時，遍歷所選文件，并寫入I列If paths.Count > 1 Theni_Row = 2For Each Item In paths.Range("I" & i_Row) = Itemi_Row = i_Row + 1NextEnd IfEnd WithEnd Sub

Tp7?? 通過對話框選擇文件-2

'通過對話框選擇文件路徑 Sub FolderPicker()Open_Path = ThisWorkbook.Sheets("操作界面").[B4]'新建一個對話框對象Set FolderDialogObject = Application.FileDialog(msoFileDialogFolderPicker)'配置對話框'配置對話框With FolderDialogObject.Title = "請選擇目標文件所在的文件夾："'添加判斷，改變對話框默認打開的路徑'默認打開上次的文件路徑If Open_Path = "" Then.InitialFileName = "C:\"Else.InitialFileName = Open_PathEnd IfEnd WithFolderDialogObject.Show '顯示對話框Set paths = FolderDialogObject.SelectedItems '獲取選擇對話框選擇的文件夾Set fso = CreateObject("Scripting.filesystemobject") '取目標文件Set myf = fso.getfolder(paths.Item(1)) '從指定路徑下獲取文件With Sheets("操作界面").[I:I].Clear.[B4].Value = paths.Item(1)i_Row = 2For Each file In myf.Files ' .Range("I" & i_Row) = file '記錄絕對路徑+文件名.Range("I" & i_Row) = file.Name '記錄文件名i_Row = i_Row + 1NextEnd WithEnd Sub

Tp8?? 從目錄頁自動跳轉至明細頁

**小提示：**權限分配表中的合并單元格，其中有一個小技巧，請參考另一篇針對篩選單元格的筆記
------------如何解決篩選時只顯示第一行------------

Private Sub Worksheet_SelectionChange(ByVal Target As Range)Dim Rng, oRng As Range ' 定義變量Rng、oRng為單元格Set Rng = Range("B2:B18") ' 設定Rng為可操作區域單元格Set oRng = Selection ' 設定oRng為選中單元格'如果所選單元格在可操作區域外，退出本次運行If Application.Intersect(oRng, Rng) Is Nothing Then Exit SubApplication.ScreenUpdating = False' 多選則退出，單選設置篩選值If Selection.Count > 1 Then Exit Sub Else AimValue = Selection.Value' 自動跳轉至目標工作表進行篩選With Sheets("權限分配表")If .FilterMode = True Then .ShowAllData.Range("A1").AutoFilter Field:=1, Criteria1:=AimValue, _Operator:=xlAnd.ActivateEnd WithApplication.ScreenUpdating = TrueEnd Sub

Tp9?? 選擇區域自動設置或取消值

Private Sub Worksheet_SelectionChange(ByVal Target As Range)Application.ScreenUpdating = FalseApplication.DisplayAlerts = FalseOn Error Resume NextDim Rng, oRngs, oRng As Range ' 定義變量Rng、oRng為單元格Dim Aim As String ' 定義變量Aim為字符串Aim = "√" ' 設定目標值Set Rng = Range("D2:H706") ' 設定Rng為可操作區域單元格Set oRngs = Selection ' 設定oRngs為選中單元格'如果所選單元格在可操作區域外，退出本次運行If Intersect(oRngs, Rng) Is Nothing Then Exit Sub' Selection.FormulaR1C1 = Aim '直接設置所選區域內的值為"√"' 針對選擇區域，有值清空，空值設定AimFor Each oRng In oRngsIf oRng.FormulaR1C1 = "" Then oRng.FormulaR1C1 = Aim Else oRng.FormulaR1C1 = ""NextOn Error GoTo 0Application.ScreenUpdating = TrueApplication.DisplayAlerts = TrueEnd Sub 未完待續、、、期待下次相遇

總結

以上是生活随笔為你收集整理的VBA常用代码合集的全部內容，希望文章能夠幫你解決所遇到的問題。

如果覺得生活随笔網站內容還不錯，歡迎將生活随笔推薦給好友。