跳转到内容

Excel VBA

Add links
100% developed
来自维基教科书，开放的书籍，为开放的世界

Microsoft Excel 是一个功能丰富的强大程序。Excel 最强大的功能之一是能够使用 Visual Basic for Applications 编写程序，这些程序在您的工作表“背后”运行，将 Excel 变成一个面向计算的开发平台，用于创建专用电子表格，这些电子表格本身可以作为应用程序使用。

服务包

[编辑 | 编辑源代码]

服务包（简称 SP）是软件程序的更新、修复或增强功能的集合，以单个可安装包的形式交付。

服务包可以是增量的，这意味着它只包含以前服务包中不存在的更新；或者它是累积的，这意味着它包含所有先前服务包的内容。在 Microsoft 产品的情况下，增量更新被称为服务版本。例如，Office 2000 必须升级到 服务版本 1 (SR-1)，然后才能安装 SP2。

宏安全

[编辑 | 编辑源代码]

宏安全设置位于信任中心。但是，如果您在组织中工作，您的系统管理员可能已更改默认设置，以防止任何人更改任何设置并执行宏。

宏录制

[编辑 | 编辑源代码]

学习 Excel VBA 的一种好方法是使用其宏录制功能。使用此功能，您可以告诉 Excel 开始录制，然后执行各种步骤，就像您在没有宏录制器的情况下工作一样，最后，告诉 Excel 停止录制。与您使用 Excel GUI 所做的操作相对应的 VBA 代码已由 Excel 录制。虽然此代码通常在没有修改的情况下无法有意义地使用，但您可以从它开始并修改它，从而节省大量原本用于阅读 VBA 文档的时间。

菜单路径

  • Excel 2000、2003：工具 > 宏 > 录制新宏。
  • Excel 2007：视图（选项卡） > 宏（组） > 宏按钮下方的向下箭头 > 录制宏
  • Excel 2007：开发人员（选项卡） > 代码（组） > 录制宏

链接

启用开发人员选项卡

[编辑 | 编辑源代码]

开发人员选项卡允许您插入各种用户界面控件，例如按钮。要使用它，您首先需要启用它。

启用选项卡的菜单路径

  • Excel 2007：圆形 Office 按钮 > Excel 选项（底部按钮） > 常规 > 在功能区中显示开发人员选项卡（复选框）
  • Excel 2010：文件（选项卡） > 选项（按钮） > 自定义功能区（按钮） > 开发人员（复选框）

链接

制作 XLA

[编辑 | 编辑源代码]

XLA 是制作 VBA 代码库的一种方法。它基本上只是一个普通的电子表格（.xls 文件），但其工作表是隐藏的。以下是创建新 XLA 的方法

  • 新建工作簿
  • 另存为... 命名为任何名字
  • 按 Alt-F11
  • 在项目树中，选择 VBAProject(whatever.xls)/ThisWorkbook
  • 按 F4 获取属性视图
  • 查找属性 IsAddin 并将其设置为 True
  • 按保存
  • 关闭 Excel
  • 将 whatever.xls 重命名为 whatever.xla

或者，您可以使用另存为/Excel 加载项。

访问注册表

[编辑 | 编辑源代码]
  • 适用于：Microsoft Excel 2002 SP-2

此方法用于读取/写入应用程序本地的键 - 这是为了为您的 VBA 应用程序提供持久设置。它不涵盖对注册表的任意访问（即查看任何键）。

VBA 子程序/函数是 SaveSetting 和 GetSetting。您可以在立即窗口中输入以下内容，以了解它们的工作原理

SaveSetting "MyApplicationName", "MyConfigSection", "MyKeyName", "Hello World"
MsgBox GetSetting("MyApplicationName", "MyConfigSection", "MyKeyName")

如果您想迭代给定部分中的所有键，您可以按如下方式进行

Sub ShowAllKeys()
   Dim mySettings As Variant
   mySettings = GetAllSettings("MyApplicationName", "MyConfigSection")
   If Not IsEmpty(MySettings) Then
      Dim counter As Integer
      For counter = LBound(mySettings) To UBound(mySettings)
          Dim keyname As String: keyname = mySettings(counter, 0)
          Dim keyval As String: keyval = mySettings(counter, 1)
          MsgBox keyname & "=" & keyval
      Next
   End If
End Sub

您也可以按如下方式删除注册表键

DeleteSetting "MyApplicationName", "MyConfigSection", "MyKeyName"

仅供参考：Excel/VBA 将此粘贴在以下注册表位置

MyComputer\HKEY_CURRENT_USER\Software\VB and VBA Program Settings\MyApplicationName\MyConfigSection

...其中 MyApplication 和 MyConfigSection 是您在 SaveSettings 调用中指定的任何内容。

它们最终位于 HKEY_CURRENT_USER\Software\VB and VBA Program Settings\MyApplicationName\MyConfigSection 中。

防止 Excel 中的确认弹出窗口

[编辑 | 编辑源代码]
  • 适用于：Microsoft Excel 2002 SP-2

从 VBA 进行以下调用

Application.DisplayAlerts = False

使单元格只读

[编辑 | 编辑源代码]
  • 适用于：Microsoft Excel 2002 SP-2
Sub ProtectMe()
  Range("A1:IV65536").Locked = False
  Range("A1").Locked = True
  ActiveSheet.Protect Password:="Test"
End Sub

查找工作表的非空部分

[编辑 | 编辑源代码]

工作表的大小最大为 65536 行 x 256 列。但是，如果您想迭代所有单元格，您可能不希望访问所有空单元格。为此，工作表提供了 UsedRange 属性。例如

ActiveSheet.UsedRange.Rows.Count

告诉您给定工作表中有多少非空行。位于第一个和最后一个使用行之间的空行也会被计算在内。示例：如果给定工作表在单元格 A7 和 B16 中有条目，则使用范围被认为是 A7:B16，总计 10 行。

使用事件

[编辑 | 编辑源代码]
  • 适用于：Microsoft Excel 2002 SP-2

考虑以下类定义——假设它是一个名为 CMyClass 的类

Option Explicit
Dim WithEvents mySheet As Worksheet

Public Sub Init(aWS as Worksheet)
   Set MySheet = aWS
End Sub

Private Sub mySheet_SelectionChange(ByVal Target As Range)
   Dim MyRange As Range
   For Each MyRange in Target
      Debug.Print CStr(MyRange)
   Next
End Sub

这里的主要思想是

  • 通过声明 mySheet WithEvents，您是在说 CMyClass 正在监听 mySheet 的事件。
  • 通过声明成员子程序 mySheet_SelectionChange，您是在指示 CMyClass 的实例在 mySheet 发生选择更改（即用户选择新的单元格或单元格范围）时应该如何反应；事件的一般模式是子程序成员变量名称_事件名称（参数）。
  • 您可以通过设置 mySheet = nothing 来断开给定工作表和 CMyClass 之间的事件绑定；
  • 您可以使用以下方法创建抛出您设计事件的类
    • 您将在类顶部声明：Public Event SomeNiceEventName(YourFavoriteParam1 as WhateverType, etc...)，
    • 然后您可以使用 RaiseEvent SomeNiceEvent("Some nice event happened."); 触发该事件（即将其触发到您的类所拥有的任何监听器）。
  • Excel 中的 VBA 不喜欢将字母 r 或 c 用作变量。这些字母在其他地方代表“行”和“列”。

这里提供了更多详细信息：[1]

警告：未捕获异常

[编辑 | 编辑源代码]

警告：事件处理程序中的未捕获异常会导致 VBE 神秘地重置。如果您在事件处理程序中导致了未捕获异常，您可能不会收到错误弹出窗口。相反，VBE 将直接重置。因此，您应该确保在所有事件处理程序中都捕获异常。

警告：联机帮助中的错别字

[编辑 | 编辑源代码]

某些版本的 Excel 的 F1 帮助中可能存在错别字。以下是一个带有正确参数的 Click 处理程序示例

 Private Sub clicksrc_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
    MsgBox "I got a click!"
 End Sub

遍历多选单元格

[编辑 | 编辑源代码]
  • 适用于：Microsoft Excel 2002 SP-2

以下代码片段将在用户选择的每个单元格中写入“YAY！”

For Each Cell in Selection
   Cell.Value = "YAY!"
Next

导出 VBA 代码

[编辑 | 编辑源代码]
  • 适用于 Microsoft Excel 2002 SP-2

以下代码提供了一个非常原始的例程，用于将模块中的 VBA 代码序列化到文件中

Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
  Dim objModule As Object
  On Error Resume Next
  
  For Each objModule In ThisWorkbook.VBProject.VBComponents
    DoEvents
    If objModule.CodeModule.CountOfLines > 0 Then
      objModule.Export objModule.Name & ".bas"
    End If
  Next objModule

End Sub

调整命名区域的大小

[编辑 | 编辑源代码]
  • Excel 2003

请注意，Range 对象的Resize 属性不会更改范围对象的大小。它返回一个新的匿名Range 对象。最简单的做法是设置调整大小后的范围的 .Name 属性

Sub ResizeRange(ByVal RangeName As String, _
                Optional NewRowCount As Long = 0, _
                Optional NewColumnCount As Long = 0)
    
  Dim oRange As Range
  Set oRange = Range(RangeName)
  If NewRowCount = 0 Then
    NewRowCount = oRange.Rows.Count
  End If
  If NewColumnCount = 0 Then
    NewColumnCount = oRange.Columns.Count
  End If
  
  oRange.Resize(NewRowCount, NewColumnCount).Name = RangeName
  
End Sub

创建命名区域

[编辑 | 编辑源代码]
  • Excel 2002

命名区域允许用户使用名称而不是单元格地址来引用单元格或单元格范围。此名称可以在其他单元格公式以及 VBA 中使用（例如，使用[SomeName]）。命名区域有两种类型：工作簿名称和工作表名称。

要创建工作簿名称，您可以选择要命名的单元格，下拉插入->名称->定义...，这将弹出“定义名称”对话框。在这里，您可以输入单元格的新名称。

要创建工作表名称，您需要按照相同的步骤进行，但将名称前面加上工作表名称!，例如Sheet1!InitialValue，以创建一个仅在工作表Sheet1 中可见的命名区域。

当有两个同名变量时，一个是局部变量（工作表名称），另一个是全局变量（工作簿名称），电子表格将使用局部变量。

没有办法可视化命名区域。最接近的是再次下拉插入->名称->定义...，但这种方法无法显示变量是局部工作表名称还是全局工作簿名称。

命名区域可以是单个单元格、行的一部分、列的一部分或一个矩形的单元格组。每个区域的行为都不同

  • 单个单元格可以在工作表的任何位置引用，或者，如果它是全局定义的（工作簿名称），则可以在任何工作表的任何位置引用。
  • 组成行一部分的单元格组只能在平行行中引用。例如，如果命名变量是mass，并且它跨越单元格 C5:L5，那么在单元格 E8 处对mass 的引用（例如，像=mass * (3e8)^2 这样的公式）将取 C8 处的的值，但在单元格 M9 处对mass 的引用将返回错误
  • 类似地，组成列一部分的单元格组只能在平行列中引用。范围之外的单元格将返回错误
  • 定义边长大于 1 的矩形数组的单元格组仅在其他工作表中引用时才有用 - 因此，没有必要在本地（工作表名称）定义它们。例如，如果covmatrix 是单元格Sheet1!B2:D4，那么如果单元格Sheet2!C3 包含公式=1/sqrt(covmatrix)，那么它将返回1/sqrt(Sheet1!C3)。

读取文件

[编辑 | 编辑源代码]

逐行读取文件，也称为遍历文件的每一行

  MyFileName = "C:\Users\Joe\Desktop\File.txt"
  FileNo = FreeFile()
  Open MyFileName For Input As #FileNo
  While Not EOF(FileNo)
    Line Input #FileNo, MyLine
    MsgBox MyLine
  Wend
  Close #FileNo

链接

  • Open 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • Close 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • Line Input 在 Visual Basic for Applications 参考资料，msdn.microsoft.com

写入文件

[编辑 | 编辑源代码]

写入文件

  MyFileName = "C:\Users\Joe\Desktop\File.txt"
  FileNo = FreeFile()
  Open MyFileName For Output As #FileNo
  For I = 1 To 10
    Print #FileNo, Str(I);
    ' The semicolon above prevents printing of a newline
  Next
  Close #FileNo

将当前工作表的制表符分隔内容写入文本文件，忽略一些单元格内容格式，例如百分比

  MyFileName = "C:\Users\Joe\Desktop\File.txt"
  FileNo = FreeFile()
  Open MyFileName For Output As #FileNo
  RowCount = ActiveSheet.UsedRange.Cells.Rows.Count
  ColumnCount = ActiveSheet.UsedRange.Cells.Columns.Count
  For RowNo = 1 To RowCount
    For ColNo = 1 To ColumnCount
      Print #FileNo, Cells(RowNo, ColNo); ' The semicolon bars newline printing
      If ColNo < ColumnCount Then
        Print #FileNo, vbTab;
      End If
    Next
    If RowNo < RowCount Then
      Print #FileNo, vbNewline;
    End If
  Next
  Close #FileNo

链接

  • Open 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • Close 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • Print # 在 Visual Basic for Applications 参考资料，msdn.microsoft.com

文件存在

[编辑 | 编辑源代码]

测试文件是否存在

  If Dir(MyFileName) <> "" Then
    MsgBox "The file exists."
  End If

目录

[编辑 | 编辑源代码]

创建目录

  MkDir "C:\Users\Joe\Desktop\TestFolder"

删除目录

  RmDir "C:\Users\Joe\Desktop\TestFolder"

更改目录

  ChDir "C:\Users"

更改当前驱动器

  ChDrive "C:"

列出目录的内容，使用包含两个文件扩展名的自定义过滤器

Directory = "C:\Users\Joe Hoe\"
Set Files = New Collection
Set FileFullPaths = New Collection
MyFile = Dir(Directory)
While MyFile <> ""
  Extension = LCase(Right(MyFile, 4))
  If Extension = ".txt" Or Extension = ".bat" Then
    Files.Add MyFile
    FileFullPaths.Add Directory & MyFile
  End If
  MyFile = Dir() 'Next file or folder
Wend

链接

  • ChDir 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • ChDrive 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • Dir 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • MkDir 在 Visual Basic for Applications 参考资料，msdn.microsoft.com
  • RmDir 在 Visual Basic for Applications 参考资料，msdn.microsoft.com

Grep

[编辑 | 编辑源代码]

在目录文件的行中搜索正则表达式，也称为 grep

Directory = "C:\Users\Joe Hoe\"
PatternString = "target.*path"
  
MyFile = Dir(Directory)
Set Lines = New Collection
Set RegExp = CreateObject("VBScript.RegExp")
RegExp.Pattern = PatternString
RegExp.IgnoreCase = True
While MyFile <> ""
  Extension = LCase(Right(MyFile, 4))
  If Extension = ".txt" Or Extension = ".bat" Then
    MyFullFileName = Directory & MyFile
    FileNo = FreeFile()
    Open MyFullFileName For Input As #FileNo
    While Not EOF(FileNo)
      Line Input #FileNo, MyLine
      If RegExp.Test(MyLine) Then
        Lines.Add MyLine
      End If
    Wend
    Close #FileNo
  End If
  MyFile = Dir() 'Next file or folder
Wend
'Lines is a collection of the matching lines

剪贴板

[编辑 | 编辑源代码]

先决条件：从 Excel 表格访问剪贴板需要在表格中设置对 MSForms（Microsoft Forms 对象库）的引用。您可以通过添加和随后删除用户窗体来设置引用，方法是通过“插入 > 用户窗体”在弹出菜单中进行操作。要检查引用的存在，请参阅“工具 > 引用”菜单。

将文本放置在剪贴板上

Set MyClipboard = New MSForms.DataObject
MyClipboard.SetText "My string"
MyClipboard.PutInClipboard

从剪贴板获取文本

Set MyClipboard = New MSForms.DataObject
MyClipboard.GetFromClipboard
TextContent = MyClipboard.GetText

链接

  • DataObject 类 在 msdn.microsoft.com 上；包含关于 Visual Basic 的部分，其对 Excel VBA 的适用性尚不清楚

范围

[编辑 | 编辑源代码]

范围是一组单元格。范围中的单元格不需要相邻。但是，单个范围中的单元格需要属于单个工作表。

定义新范围

Set MyRange = Selection 'The current selection, possibly of multiple cells
Set MyRange = ActiveCell 'The single active cell
Set MyRange = Cells(1, 2) 'Row=1, Column=2 AKA B
Set MyRange = Cells(1, 1).Offset(0, 1) '=Cells(1, 2)
Set MyRange = Cells(1, 2).Offset(0, -1) '=Cells(1, 1)
Set MyRange = Cells(1, 1).Offset(0, -1) 'An error
Set MyRange = Range("A1:C2") 'Letters indicate columns; numbers indicate rows
Set MyRange = Range("A1:A3,C1:C3") 'A discontinuous range
Set MyRange = Range("B2:C2").Cells(1, 1) '=Cells(2, 2) =Range("B2")
Set MyRange = Rows(1) 'An entire row
Set MyRange = Columns(1) 'An entire column
Set MyRange = Cells(2,2).EntireRow
Set MyRange = Cells(2,2).EntireColumn
Set MyRange = Range("B1:C1").EntireColumn 'Two entire columns
Set MyRange = Range("B2:D4").End(xlUp) '=Cells(1, 2) =Range("B1")
Set MyRange = Range("B2:D4").End(xlToLeft) '=Cells(2, 1) = Range("A2")
Set MyRange = Range("B2:D4").End(xlDown) '=Cells(<last row number>, 2)
Set MyRange = Range("B2:D4").End(xlToRight) '=Cells(2, <last column number>)

遍历范围，也称为遍历范围中的每个单元格

Set MyRange = Selection
For Each Cell in MyRange
  MsgBox Cell
Next

遍历行和遍历列，也称为遍历范围的每一行和每一列，即使是不连续的

Set Rng = Range("A1:B1,D3:E3") 'Discontiguous range
For Each Row In Rng.Rows
  RowNo = Row.Row
Next
For Each Column In Rng.Columns
  ColNo = Column.Column
Next

创建两个范围的并集（包含两个范围的范围）或交集（仅覆盖共同单元格的范围）

Set MyRange = Range("A1:C2")
Set MyRange = Union(MyRange, Range("A5:C5"))
MyRange.Interior.Color = RGB(230, 230, 0)
Set MyRange = Intersect(MyRange, Columns(2))
MyRange.Interior.Color = RGB(230, 100, 0)

选择范围

Set MyRange = Sheets(1).Range("A1:B1,D1:E1")
MyRange.Select 'Even a discontinuous range can be selected

激活单元格

Range("A1:B2").Select 'Affects Selection, generally of multiple cells
Range("A2").Activate 'Affects ActiveCell, the single one

了解一个区域，即学习一个区域，包括单元格数量、第一行、最后一行、第一列、最后一列、行数和列数

Set Rng = Range("B2:D4") 'Contiguous range
NumberOfCells = Rng.Cells.Count
FirstRowNo = Rng.Row
LastRowNo = Rng.Row + Rng.Rows.Count - 1 'Only for contiguous ranges
FirstColNo = Rng.Column
LastColNo = Rng.Column + Rng.Columns.Count - 1 'Only for contiguous ranges

Set Rng = Range("A1:B1,D1:E1") 'Discontiguous range
BrokenLastColNo = Rng.Column + Rng.Columns.Count - 1 'Only for contiguous ranges
'Do it the correct way for discontiguous range
LastColNo = 0
For Each Cell in Rng
  If Cell.Column > LastColNo then
    LastColNo = Cell.Column
  End If
Next

Set RangeWorksheet = Rng.Worksheet

链接

工作表

[编辑 | 编辑源代码]

要创建、访问或删除工作表，您可以使用工作表对象的各种方法。以下是示例。

Set MyNewWorksheet = Sheets.Add 'Create
Set MyNewWorksheet2 = Sheets.Add(After:=Sheets(Sheets.Count)) 'Create and place as the last sheet
MyNewWorksheet.Name = "My Sheet"
Set IndexedWorksheet = Sheets(1) 'Access by index
Set NamedWorksheet = Sheets("Name") 'Access by name
Set NamedWorksheet2 = Worksheets("Name") 'Does the same thing as the line above
MyNewWorksheet.Delete
Sheets("Name").Cells(1,1) = "New Value" 'Access the cells of the worksheet
Sheets("Name").Cells.Clear 'Clear an entire worksheet, including formatting and cell values
Sheets("Name").Columns(1).Sort key1:=Sheets("Name").Range("A1") 'Sort the first column
Sheets("Name").Columns(1).Sort key1:=Sheets("Name").Range("A1"), _
  order1:=xlDescending, header:=xlYes 'Use descending instead of ascending; do not sort
                                      ' the first cell, considering it a header
MyNewWorksheet2.Visible = xlSheetHidden
MyNewWorksheet2.Visible = xlSheetVisible

通过名称获取现有工作表，或在不存在时创建它

NewSheetName = "My Sheet"
Set MySheet = Nothing
On Error Resume Next
Set MySheet = Sheets(NewSheetName)
On Error GoTo 0
If MySheet Is Nothing Then
  Set MySheet = Sheets.Add(After:=Sheets(Sheets.Count))
  MySheet.Name = NewSheetName
End If

链接

搜索

[编辑 | 编辑源代码]

您可以按照以下步骤在工作表中搜索值

Dim SoughtString As String
SoughtString = "London"
Set ForeignKeySheet = Sheets("CitySize")
Set FoundCell = ForeignKeySheet.Columns(1).Find(SoughtString, LookAt:=xlWhole)
If Not FoundCell Is Nothing Then
  'The value associated with the key is in column 2
  CitySize = FoundCell.Offset(0, 1)
End If

如果您想要进行子字符串匹配，请删除“LookAt:=xlWhole”，或使用“LookAt:=xlPart”。

链接

单元格格式

[编辑 | 编辑源代码]

您可以对单元格进行格式设置，包括文本颜色、背景颜色、字体属性和边框，还可以从 VBA 中对数字、百分比或文本进行格式设置，如下所示

  Selection.Characters.Font.Color = RGB(0, 0, 255) 'Foreground color AKA text color
  Selection.Interior.Color = RGB(230, 230, 230) 'Background color
  Selection.Characters.Font.ColorIndex = xlAutomatic 'Reset foreground color
  Selection.Interior.Color = xlAutomatic 'Reset background color
  Selection.Font.Name = "Verdana" 'Font face
  Selection.Font.Size = 8 'Font size
  Selection.Font.Bold = True
  Selection.Font.Italic = True
  Selection.Font.Underline = True
  'Selection.Font.Strikethrough = True
  Selection.Font.Name = Application.StandardFont 'See also ClearFormats below
  Selection.Font.Size = Application.StandardFontSize 'See also ClearFormats below
  'Selection.Borders.LineStyle = xlLineStyleNone or xlDouble or xlDashDotDot or other
  Selection.Borders.Weight = xlMedium ' xlHairline, xlThin, xlMedium, or xlThick
  'Selection.Borders(xlEdgeBottom).Weight = xlThick
  ' LineStyle and Weight interact in strange ways.
  Selection.Borders.Color = RGB(127, 127, 0) 'Will be overridden below; applies to all borders
  Selection.Borders(xlEdgeBottom).Color = RGB(255, 0, 0)
  Selection.Borders(xlEdgeTop).Color = RGB(0, 255, 0)
  Selection.Borders(xlEdgeLeft).Color = RGB(0, 0, 255)
  Selection.Borders(xlEdgeRight).Color = RGB(0, 127, 127)
  Selection.Borders(xlInsideHorizontal).Color = &H7FFF00 'A tricky hex matching RGB(0, 255, 127)
  Selection.Borders(xlInsideVertical).Color = RGB(255, 127, 0)

  Selection.NumberFormat = "General"
  Selection.NumberFormat = "00" 'As a number with zero decimal places, showing at least two digits
  Selection.NumberFormat = "0.000" 'As a number, showing three decimal places and no more
  Selection.NumberFormat = "0.0%" 'As a percent with one decimal place
  Selection.NumberFormat = "@" 'As text
  Selection.NumberFormat = "0.00E+00" 'As a number in scientific notation,
                                      'the string before E formatting the significand
  Selection.NumberFormat = "m/d/yyyy" 'As a date; whether "/" is shown depends on locale
  Selection.NumberFormat = "d. mmmm yyyy hh:mm:ss" 'As date, showing the month using a word,
                                      'also showing time
                                        
  Selection.ClearFormats 'Remove formatting, keeping cell content.
                         'Removes also the formatting set using NumberFormat.

链接

颜色

[编辑 | 编辑源代码]

在 Excel VBA 中，RGB 颜色是普通数字，而不是对象。一些颜色示例列在 #单元格格式 中。

一些示例

Selection.Characters.Font.Color = RGB(0, 0, 255) 'Foreground color AKA text color
Selection.Interior.Color = RGB(230, 230, 230) 'Background color
Selection.Characters.Font.ColorIndex = xlAutomatic 'Reset foreground color
Selection.Comment.Shape.Fill.ForeColor.RGB = RGB(220, 255, 160)
'The above is the fill color, that is, the background color
Selection.Comment.Shape.TextFrame.Characters.Font.ColorIndex = 3 'Red per default
'Selection.Comment.Shape.TextFrame.Characters.Font.Color = RGB(255, 0, 0) 'Does not work in Excel 2007
If False Then
  ActiveWorkbook.Colors(3) = RGB(200, 0, 0) 'Make the red in the index 5 a bit darker
End If

将第一列单元格的背景颜色设置为行号颜色索引

For ColorIndex = 1 to 56
  Cells(ColorIndex,1).Interior.ColorIndex = ColorIndex 
Next

默认调色板中的颜色索引

  • 0 - 自动
  • 1 - 黑色
  • 2 - 白色
  • 3 - 红色
  • 4 - 绿色
  • 5 - 蓝色
  • 6 - 黄色
  • 7 - 洋红色
  • 8 - 青色
  • 9 - 深红色
  • 10 - 深绿色
  • 11 - 深蓝色
  • ...等等，一直到 56

查找所有文本颜色接近绿色的单元格

  TargetColor = RGB(0, 255, 0)
  Tolerance = 200
  'Extract the color components. The extraction is unneeded, but if the target
  'color came from the color of a selected cell, it would be needed.
  TmpColor = TargetColor
  TargetColorRed = TmpColor Mod 256
  TmpColor = TmpColor \ 256
  TargetColorGreen = TmpColor Mod 256
  TmpColor = TmpColor \ 256
  TargetColorBlue = TmpColor Mod 256

  For Each Cell In ActiveSheet.UsedRange.Cells
    MyColor = Cell.Characters.Font.Color 'Color is a number
    'Extract the RGB components of the color
    Red = MyColor Mod 256
    MyColor = MyColor \ 256
    Green = MyColor Mod 256
    MyColor = MyColor \ 256
    Blue = MyColor Mod 256
    'Find the distance from the target color
    Distance = ((Red - TargetColorRed) ^ 2 + _
                (Green - TargetColorGreen) ^ 2 + _
                (Blue - TargetColorBlue) ^ 2) ^ 0.5
    If Distance < Tolerance Then
      Cell.Interior.Color = RGB(230, 230, 230) 'Mark the cell using its background color
    End If
  Next

链接

可见性

[编辑 | 编辑源代码]

隐藏一行（隐藏一行，隐藏行）

Rows(2).Hidden = True
'Rows(2).Hidden = False 'Show it again

一次隐藏多行

Range("A1:A3").EntireRow.Hidden = True 'Hide rows 1, 2, and 3

隐藏当前选定单元格所在的行

Selection.EntireRow.Hidden = True

循环遍历可见的行（即显示的行，即未隐藏的行）

For RowNo = 1 To 10
  If Not Rows(RowNo).Hidden Then
    'Do something on the row
  End If
Next

切换行的可见性

For RowNo = 1 To 10
  If Not Rows(RowNo).Hidden Then
    Rows(RowNo).Hidden = True
  Else
    Rows(RowNo).Hidden = False
  End If
Next

隐藏一列（隐藏一列，隐藏列）

Columns(2).Hidden = True
'Columns(2).Hidden = False 'Show it again

一次隐藏多列

Range("A1:C1").EntireColumn.Hidden = True 'Hide columns 1, 2, and 3

隐藏当前选定单元格所在的列

Selection.EntireColumn.Hidden = True

其他与列可见性相关的技巧与上面行示例完全类似。

[编辑 | 编辑源代码]

打开或访问超链接（打开超链接，访问超链接，打开超链接，访问超链接）

ActiveWorkbook.FollowHyperlink "http://www.microsoft.com"

通过打开一个组合好的 URL，打开当前活动单元格中文章标题对应的维基百科文章

ActiveWorkbook.FollowHyperlink "http://en.wikipedia.org/wiki/" & ActiveCell

打开当前选定单元格中任意文章标题对应的维基百科文章

For Each Cell In Selection
  ActiveWorkbook.FollowHyperlink "http://en.wikipedia.org/wiki/" & Cell
Next

打开本地超链接，可能会弹出一个弹出窗口，出于安全原因需要确认

ActiveWorkbook.FollowHyperlink "file://C:\Users\Joe Hoe\Desktop\Test.txt"

链接

临时文件

[编辑 | 编辑源代码]

获取临时文件，以下方法的稳健性尚不清楚，该方法使用随机数并测试文件是否存在

Function GetTempFile(Prefix As String, Suffix As String) As String
  TempFolder = Environ$("tmp")
  Randomize
  While True
    TempFileName = TempFolder & "\" & Prefix & CStr(Int(10000000 * Rnd)) & Suffix
    If Dir(TempFileName) = "" Then 'Then the file does not exist
      GetTempFile = TempFileName
      Exit Function
    End If
  Wend
End Function

链接

命令输出

[编辑 | 编辑源代码]

如果您不介意弹出控制台窗口，这里介绍一种从 Excel VBA 获取命令输出的方法

Set MyShell = CreateObject("WScript.Shell")
Set ExecObject = MyShell.Exec("tasklist /v")
' AllText = ExecObject.StdOut.ReadAll
Do While Not ExecObject.StdOut.AtEndOfStream
  Line = ExecObject.StdOut.ReadLine()
  If InStr(Line, "AcroRd32.exe") > 0 Then
    'Do something
  End If
Loop

如果您无法接受弹出控制台窗口，并且愿意创建一个临时文件，这里介绍另一种从 Excel VBA 获取命令输出的方法

'Summary: Run "attrib" on the file in column A (1) of the row
'of the currently selected cell, writing the result into
'column B (2) of the row.

'Get temp file name
TempFolder = Environ$("tmp")
Randomize
TempFileName = ""
While TempFileName = ""
  TempFileNameCand = TempFolder & "\" & "mytmp" & CStr(Int(10000000 * Rnd)) & ".tmp"
  If Dir(TempFileNameCand) = "" Then 'Then the file does not exist
    TempFileName = TempFileNameCand
  End If
Wend
 
'Run the command
Set MyShell = CreateObject("WScript.Shell")
MyCommand = "cmd /c attrib """ & Cells(Selection.Row, 1) & """ >" & TempFileName
MyShell.Run MyCommand, 0, True '0 = show no window
'Although attrib has an exe file, we need to use "cmd" for the
'redirection to work.

FileNo = FreeFile()
Open TempFileName For Input As #FileNo
While Not EOF(FileNo)
  Line Input #FileNo, MyLine
  Cells(Selection.Row, 2) = MyLine
Wend
Close #FileNo
Kill TempFileName 'Delete the file to clean up, although not strictly necessary

使用 cmd /c，您可以运行使用 & 或 | 连接的命令链

Set MyShell = CreateObject("WScript.Shell")
Set ExecObject = MyShell.Exec("cmd /c cd /d C:\Users\Joe Hoe & findstr /s knowledge *.txt")
' AllText = ExecObject.StdOut.ReadAll
Do While Not ExecObject.StdOut.AtEndOfStream
  Line = ExecObject.StdOut.ReadLine()
  'Do something
Loop

链接

维度

[编辑 | 编辑源代码]

行高和列宽

Selection.RowHeight = 15
Cells(1,1).RowHeight = 15 'Can be applied to cells, not only to rows
Rows(4).AutoFit 'Automatically adjust row height
'Cells(4, 1).AutoFit 'Error
Cells(4, 1).EntireRow.AutoFit
Selection.EntireRow.AutoFit 'Auto fit the row height of the current selection
ActiveSheet.UsedRange.Rows.AutoFit 'Auto fit the row height of the entire sheet
Selection.RowHeight = ActiveSheet.StandardHeight

Columns(1).ColumnWidth = 70
Cells(1,1).ColumnWidth = 70 'Can be applied to cells, not only to columns
Columns(2).AutoFit 'Automatically adjust column width
Selection.EntireRow.AutoFit 'Auto fit the column width of the current selection
ActiveSheet.UsedRange.Columns.AutoFit 'Auto fit the column width of the entire sheet
Selection.ColumnWidth = ActiveSheet.StandardWidth

链接

注释

[编辑 | 编辑源代码]

使用注释（即笔记）

If Cells(1,1).Comment Is Nothing Then
  Cells(1,1).AddComment Text:="Hey"
  'AddComment throws an error if the cell already has a comment
  'Range("A2:A3").AddComment Text:="Hey" 'Error
  'AddComment throws an error if applies to more than one cell at once.
End If
Cells(1,1).Comment.Text Text:=Selection.Comment.Text & " there"
Cells(1,1).Comment.Visible = True 'Prevent the comment from autohiding
Cells(1,1).Comment.Visible = False 'The default setting
Cells(1,1).Comment.Shape.Fill.ForeColor.RGB = RGB(220, 255, 160)
'The above is the fill color, that is, the background color
Cells(1,1).Comment.Shape.Height = 60
Cells(1,1).Comment.Shape.Width = 80
Cells(1,1).Comment.Shape.TextFrame.Characters.Font.Name = "Verdana"
Cells(1,1).Comment.Shape.TextFrame.Characters.Font.Size = 9
Cells(1,1).Comment.Shape.TextFrame.Characters(1, 3).Font.Bold = True
If False Then
  'Selection.Comment.Delete
  Cells(1,1).ClearComments
  Range("A1:A2").ClearComments 'Can apply to several cells at once
  Cells(1,1).PasteSpecial Paste:=xlPasteComments
End If

将工作表的所有注释收集到一个字符串中

CommentString = ""
For Each Comment in ActiveSheet.Comments
  CommentString = CommentString & " " & Comment.Text
Next

链接

IsEmpty

[编辑 | 编辑源代码]

简单来说，判断一个变量是否已初始化但尚未写入。

可用于判断单元格是否为空；单元格附加的注释或单元格格式的存在并不会使单元格变为非空。

示例

Set MyCell = Cells(1, 1)
If IsEmpty(MyCell) Then
  MyCell.Value = "New value"
End If
'
MyCell.Value = ""
Result1 = IsEmpty(MyCell) 'True
'
Dim MyVar
Result2 = IsEmpty(MyVar) 'True
MyVar = ""
Result3 = IsEmpty(MyVar) 'False
MyVar = Empty
Result4 = IsEmpty(MyVar) 'True

链接

  • IsEmpty，位于 MSDN 上的 Excel 2010 VBA 语言参考

IsNull

[编辑 | 编辑源代码]

判断表达式是否为 Null，这与 Empty 不同。

Null 可以分配给变体变量；它不能分配给声明为字符串或整数的变量。Null 不能分配给对象，与 Nothing 不同。

示例

Result1 = IsNull(Null)   'True
Result2 = IsNull(Empty)  'False
'
Dim MyVar As Variant
MyVar = Null             'All right
Result3 = IsNull(MyVar)  'True
Dim MyColl As Collection
Set MyColl = Nothing     'All right
Set MyColl = Null        'Error
Dim MyStr As String
MyStr = Null             'Error
Dim MyInt As Integer
MyInt = Null             'Error

链接

  • IsNull 在 MSDN 上的 Excel 2013 VBA 语言参考

启动时加载的加载项

[编辑 | 编辑源代码]

控制 Excel 启动时打开的加载项

Microsoft Excel 2003: 通过“工具” -> “加载项” 配置加载的加载项。他们的列表在以下注册表项中镜像，但在编辑注册表时没有优势

HKCU\Software\Microsoft\Office\11.0\Excel\Init Commands

Microsoft Excel 2002 SP-2: 当您启动 Excel 时，它可能会自动加载加载项（即您从“工具” -> “加载项” 添加的加载项）。加载的加载项列表来自以下注册表项

HKCU\Software\Microsoft\Office\10.0\Excel\Options

在此项下，您可能会发现字符串变量列表

  • OPEN
  • OPEN1
  • OPEN2
  • 等等...

这些变量的值是加载项的名称。Excel 在启动时，将尝试首先加载字符串变量 OPEN 中的加载项，然后加载 OPEN1（如果存在），依此类推，直到没有这样的字符串变量为止。看起来 Excel 会在键不连续时自动重新编号它们（例如，OPEN1、OPEN3、OPEN4 将变为 OPEN1、OPEN2、OPEN3）。

还要注意，当您执行“工具” -> “加载项” 时显示的加载项列表，部分来自以下项的内容

HKCU\Software\Microsoft\Office\10.0\Excel\Addin Manager

另请参阅以下 Microsoft 知识库文章：如何从加载项对话框中删除条目。

直接从 VBA 数组数据创建图表

[编辑 | 编辑源代码]

图表不必基于电子表格单元格中的值，也可以直接在 VBA 中从数组创建。以下代码创建了字符串中字符相对频率的图表，以百分比形式显示，或归一化为最大值 1。还可以选择排序显示，并且可以通过修改 vRef 数组的内容或顺序来更改内容。还包括用于删除图表和测试函数的过程。

Sub TestChartOfStrFreq()
    'run this to make a chart
    
    Dim str As String, n As Long, c As Long
    
    'place user string here
    str = ""
    
    'if no user string use these random charas
    If str = "" Then
        Do
           DoEvents
           Randomize
           n = Int((127 - 0 + 1) * Rnd + 0)
            Select Case n
            'numbers, and upper and lower letters
            Case 48 To 57, 65 To 90, 97 To 122
               str = str & Chr(n)
               c = c + 1
            End Select
        Loop Until c = 1000
    End If
        
    If ChartOfStrFreq(str, 1, 1) Then MsgBox "Chart done..."

End Sub

Sub DeleteAllWorkbookCharts5()
'run this to delete all charts
    Dim oC
    Application.DisplayAlerts = False
        For Each oC In ThisWorkbook.Charts
           oC.Delete
        Next oC
    Application.DisplayAlerts = True

End Sub

Function ChartOfStrFreq(sIn As String, Optional bSort As Boolean = False, Optional bNormalize As Boolean = False) As Boolean
'makes Excel bar-graph chart for percentage incidence of vRef charas in string (or normalized to max value= 1)
'bSort = True for descending percent otherwise vRef sequence

'PREP
    Dim vRef As Variant, LBC As Long, UBC As Long, LBR As Long, UBR As Long
    Dim vW() As Variant, x() As Variant, y() As Variant
    Dim sUC As String, nC As Long, n As Long, sS As String, nS As Long
    Dim vR As Variant, bCond As Boolean, SortIndex As Long, temp As Variant
    Dim t As Variant, i As Long, j As Long, q As Long, max As Variant
    Dim bXValueLabels As Boolean, sT As String, sX As String, sY As String
    
    If sIn = "" Then
       MsgBox "Empty input string - closing"
       Exit Function
    End If
    
    'load the intended x-axis display set here...add to it and delete as required
    vRef = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
                 "N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
                 "0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
    
    'set axis labels etc...
    sT = "Selective Distribution from a " & Len(sIn) & "-Character String"
    sX = "Character Set of Interest"
    If bNormalize Then
       sY = "Count Divided by Maximum Value"
    Else
       sY = "Percentage of Original String"
    End If
    bXValueLabels = True
    
    
    LBC = LBound(vRef): UBC = UBound(vRef)
    ReDim vW(0 To 2, LBC To UBC)
    LBR = LBound(vW, 1): UBR = UBound(vW, 1)
    ReDim x(LBC To UBC)
    ReDim y(LBC To UBC)

'COUNT
    sUC = UCase(sIn)
    nC = Len(sIn)
    For n = LBC To UBC
       vW(0, n) = vRef(n) 'all charas to first row
       sS = vW(0, n)
       'count hits in string for each chara in ref set
       vW(1, n) = UBound(Split(sUC, sS)) - LBound(Split(sUC, sS)) 'count hits
       'calculate hits as percentages of total chara count
       vW(2, n) = Round(((vW(1, n)) * 100 / nC), 2)
    Next n

'NORMALIZE
    If bNormalize Then
        max = vW(1, FindMax(vW, 1))
        For n = LBC To UBC
           temp = vW(1, n)
           vW(2, n) = Round((temp / max), 2)
        Next n
    End If

'SORT
    If bSort Then
        SortIndex = 2
        'descending sort, on rows
        For i = LBC To UBC - 1
            For j = LBC To UBC - 1
                bCond = vW(SortIndex, j) < vW(SortIndex, j + 1)
                If bCond Then
                    For q = LBR To UBR
                        t = vW(q, j)
                        vW(q, j) = vW(q, j + 1)
                        vW(q, j + 1) = t
                    Next q
                End If
            Next
        Next
    End If

'CHART
    'transfer data to chart arrays
    For n = LBC To UBC
        x(n) = vW(0, n) 'x axis data
        y(n) = vW(2, n) 'y axis data
    Next n

    'make chart
    Charts.Add
    ActiveChart.ChartType = xlColumnClustered 'column chart
       
    'assign the data and labels to a series
    With ActiveChart.SeriesCollection
       If .count = 0 Then .NewSeries
          If bXValueLabels Then
             .Item(1).ApplyDataLabels Type:=xlDataLabelsShowValue
             .Item(1).DataLabels.Orientation = 60
          End If
       If Val(Application.Version) >= 12 Then
          .Item(1).Values = y
          .Item(1).XValues = x
       Else
          .Item(1).Select
          Names.Add "_", x
          ExecuteExcel4Macro "series.x(!_)"
          Names.Add "_", y
          ExecuteExcel4Macro "series.y(,!_)"
          Names("_").Delete
       End If
    End With
    
    'apply title string, x and y axis strings, and delete legend
    With ActiveChart
       .HasTitle = True
       .ChartTitle.Text = sT
       .SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
       .Axes(xlCategory).AxisTitle.Text = sX
       .SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
       .Axes(xlValue).AxisTitle.Text = sY
       .Legend.Delete
    End With
         
    ActiveChart.ChartArea.Select

ChartOfStrFreq = True
    
End Function

Public Function FindMax(arr() As Variant, row As Long) As Long
  Dim myMax As Long
  Dim i As Long
  
  For i = LBound(arr, 2) To UBound(arr, 2)
    If arr(row, i) > myMax Then
      myMax = arr(row, i)
      FindMax = i
    End If
  Next i
End Function

清除保留状态

[编辑 | 编辑源代码]
  • 适用于：Microsoft Excel 2002 SP-2
  • 操作系统：Windows XP

清除 Excel 保留状态：Excel 在运行之间会记住各种事情：要加载哪些加载项，要显示哪些按钮和菜单等等。有时您可能想要清除所有这些东西，并将 Excel 恢复到出厂状态。

清除 Excel 清单

  1. 确保以下目录为空
    1. C:\Program Files\Microsoft Office\Office10\xlstart
    2. C:\apps\xp\application data\Microsoft\xlstart
  2. 从注册表中清除自动打开键（如下所示）；
  3. 清除所有 .xlbs - 例如，在此处检查
    1. C:\apps\xp\application data\Microsoft\Excel
[编辑 | 编辑源代码]
[编辑 | 编辑源代码]
检索自 "https://wikibooks.cn/w/index.php?title=Excel_VBA&oldid=4005080"
华夏公益教科书