常用VBA集锦（更新）

Mengkelyu

建议在每个Module（模块）的代码前面加上

Option explicit
Option base 1
'or 
Option base 0

这里Option explicit指的是所有变量需要声明变量类型（用Dim来声明变量），否则会报错。这个可以强制我们定义每一个变量的类型，并拥有一个好的代码习惯。

Option base指的是默认数组从哪里开始。1指的是从1开始，0指的是从0开始。
如果你习惯用Python就会知道，python数组默认从0开始。
而R默认从1开始。

数组Array写入单元格 / 单元格中读取数组Array

读取

Dim arr as Variant
Arr = range(“whateverrange”).value

写入：注意，这里数组最好用二元而非一元数组。
这里的whateverrange指的是写入的Range的第一个单元格。这样写的好处是不需要自己想arr到底有几行几列

Dim arr(100, 1)

range(“whateverrange”).resize(UBound(arr, 1), UBound(arr, 2)).Value = arr

在不显示弹窗的基础上删除Sheet

Sub Delete_Sheet_WithoutWarningMessage()
    Application.DisplayAlerts = False
    Sheets("Sheet2").Delete
    Application.DisplayAlerts = True
End Sub

如果Sheet不存在，创建Sheet。

Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
    Dim sht As Worksheet

    If wb Is Nothing Then Set wb = ThisWorkbook
    On Error Resume Next
    Set sht = wb.Sheets(shtName)
    On Error GoTo 0
    WorksheetExists = Not sht Is Nothing
End Function

If WorksheetExists("md_table") = False Then Sheets.Add(After:=Sheets(Sheets.Count)).Name = "md_table"

创建Workbook

Dim wb as Workbook
Workbooks.Add
Set wb = ActiveWorkbook
wb.SaveAs Filename:="your_path\NewWB.xlsx"

在excel的Status bar显示运行的process

Private Sub ProgressTime(Message As String, percentage As Single)
Dim prog_Bar As String
'progress bar
    prog_Bar = Mid(String(20, ChrW(9632)) + String(20, ChrW(9633)), Round(20 + 1 - percentage * 20, 0), 20)
    
'Output
Application.StatusBar = Message & "  " & prog_Bar
End Sub

根据给定的画图

Private Sub draw_chart(sheet_name As String, graph_type As String, axis_rng As Range, data_rng As Range)
    Dim chart_my    As Shape
    
    For Each chtObj In Worksheets(sheet_name).ChartObjects
        chtObj.Delete
    Next
    
    Select Case graph_type
        Case Is = "Bar Chart"
            Set chart_my = Worksheets(sheet_name).Shapes.AddChart2(-1, XlChartType:=xlBarClustered)
        Case Is = "Column Chart"
            Set chart_my = Worksheets(sheet_name).Shapes.AddChart2(-1, XlChartType:=xlColumnClustered)
        Case Is = "Line Chart"
            Set chart_my = Worksheets(sheet_name).Shapes.AddChart2(-1, XlChartType:=xlLineMarkers)
        Case Is = "3D Column"
            Set chart_my = Worksheets(sheet_name).Shapes.AddChart2(-1, XlChartType:=xl3DColumnClustered)
        Case Is = "3D Bar"
            Set chart_my = Worksheets(sheet_name).Shapes.AddChart2(-1, XlChartType:=xl3DBarClustered)
        Case Is = "3D Line"
            Set chart_my = Worksheets(sheet_name).Shapes.AddChart2(-1, XlChartType:=xl3DLine)
    End Select
    
    chart_my.Chart.SetSourceData Source:=data_rng
    chart_my.Chart.FullSeriesCollection(1).XValues = axis_rng
End Sub

计算运行时间。
https://www.thespreadsheetguru.com/the-code-vault/2015/1/28/vba-calculate-macro-run-time

Sub CalculateRunTime_Seconds()
'PURPOSE: Determine how many seconds it took for code to completely run
'SOURCE: www.TheSpreadsheetGuru.com/the-code-vault

Dim StartTime As Double
Dim SecondsElapsed As Double

'Remember time when macro starts
  StartTime = Timer

'*****************************
'Insert Your Code Here...
'*****************************

'Determine how many seconds code took to run
  SecondsElapsed = Round(Timer - StartTime, 2)

'Notify user in seconds
  MsgBox "This code ran successfully in " & SecondsElapsed & " seconds", vbInformation

End Sub

Mengkelyu

Error handling:

On error resume next

定义变量

Dim strName As String 

Dim intX As Integer, intY As Integer, intZ As Integer 
'在下面的语句中，intX 和 intY 都声明为 **** Variant 类型；只有 intZ 声明为 Integer 类型。! 注意!
Dim intX, intY, intZ As Integer

循环: Do...While

Do While [Condition]
        [Statement~~strikethrough text~~]
        Loop

加快代码运行

Application.Calculation = xlManual
Application.ScreenUpdating = False

[Code]

Application.ScreenUpdating = True
Application.Calculation = xlAutomatic

Mengkelyu

列出所有工作表的名称

Sub ListSheets()

Dim ws As Worksheet
Dim x As Integer

x = 1

Sheets("Sheet1").Range("A:A").Clear

For Each ws In Worksheets
     Sheets("Sheet1").Cells(x, 1) = ws.Name
     x = x + 1
Next ws

End Sub

Mengkelyu

在隐藏的状况下打开关闭工作薄

'Open Workbook
Set wbResults = Workbooks.Open(Filename:="your path (包含路径)", UpdateLinks:=0, ReadOnly:=True)
wbResults.Windows(1).Visible = False
        
'Close workbook
wbResults.Close SaveChanges:=False

Mengkelyu

得到某个范围里最后一行的行数

假设rg是这个范围，lastRow 是我们想要得到的行数

lastRow = rg.Rows(rg.Rows.Count).Row

Mengkelyu

打开一个文件夹内所有工作表

Sub Open_all_excel_files_in_folder()
Dim FoldPath As String
Dim DialogBox As FileDialog
Dim FileOpen As String
On Error Resume Next
Set DialogBox = Application.FileDialog(msoFileDialogFolderPicker)
If DialogBox.Show = -1 Then
FoldPath = DialogBox.SelectedItems(1)
End If

If FoldPath = "" Then Exit Sub
FileOpen = Dir(FoldPath & "\*.xls*")
Do While FileOpen <> ""
Workbooks.Open FoldPath & "\" & FileOpen
FileOpen = Dir
Loop

End Sub