VBA 常用的VBA短句（带注释）

带解释的 VBA 短句

[VBA起步]常用的、带解释的 VBA 短句

[A65536].End(xlUp).Row                            'A列末行向上第一个有值的行数

[A1].End(xlDown).Row                               'A列首行向下第一个有值之行数

[IV1].End(xlToLeft).Column                        '第一行末列向左第一列有数值之列数。

[A1].End(xlToRight).Column                       '第一行首列向右有连续值的末列之列数

Application.CommandBars("Standard").Controls(2).BeginGroup=True '在常用工具栏的第二个按钮前插入分隔符

Cells.WrapText = False             '取消自动换行

    If Len(Target) > 5 Then           '如果当前单元格中的字符数超过5个,执行下一行

        Target.WrapText = True        '自动换行

    End If

[A1:B10].SpecialCells(xlCellTypeBlanks).Rows.Hidden = True      '有空格即隐藏行

[A2].parent.name                                                '返回活动单元格的工作表名

[A2].parent.parent.name                                         '返回活动单元格的工作簿名

如下代码可使工作簿打开后30秒(或闲置30秒)内不输入、不重新选择等,自动关闭工作簿

Private Sub Workbook_Open()               '工作簿打开事件

   tt                                     '工作簿打开时启动 tt 过程

End Sub

Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)  '工作表变化事件

   tt                                                                '工作表中任一单元格有变化时启动 tt 过程

End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range) '工作表选择变化事件

   tt                                                            '工作表中单元格的选择有变化时启动 tt 过程

End Sub

Sub tt()                                       'tt 过程

   Dim myNow As Date, BL As Integer            '定义myNow为日期型;定义BL为长整型 

   myNow = Now                                 '把当前的时间赋给变量myNow

   Do                                          '开始循环语句Do

      BL = Second(Now) - Second(myNow)         '循环中不断检查变量BL的值

      If BL = 30 Then GoTo Cl                  '当BL=30即跳转到CL

      DoEvents                                 '转让控制权,以便sheets可继续操作

   Loop Until BL > 30                          '当BL>30即跳出循环

   Exit Sub

Cl:

   Application.EnableEvents = False            '避免引起其他事件 

   ActiveWorkbook.Close True                   '关闭活动工作簿并保存

   Application.EnableEvents = True             '可触发其他事件

End Sub

range("e4").addcomment.Text "代头" & Chr(10) & "内容……"         '添加批注 

range("e4").Comment.Visible = True                     '显示批注

把工作簿中所有工作表的指定列调整为最佳列宽：

Sub 调整列宽()

   Dim i%                 

   For i = 1 To Sheets.Count                '遍历工作簿中所有的工作表

      Sheets(i).Columns("A:K").AutoFit      '把每个工作表的[A:K]列调整为最佳列宽

   Next i                                    

End Sub

Do循环语句的几种形式:

1. 

Do While i>1     '条件为True时执行

... ...  '要执行的语句

Loop

2.

Do Until i>1     '条件为False时执行

... ...  '要执行的语句

Loop

3.

Do 

... ...  '要执行的语句

Loop While i>1   '条件为True时执行

4.

Do 

... ...  '要执行的语句

Loop Until i>1   '条件为False时执行

5.While...Wend 语句

While i>1        '条件为True时执行

... ...  '要执行的语句

Wend

勾选"VBA项目的信任"

Application.SendKeys "%(tmstv){ENTER}"                 '在 Excel 窗口操作

Application.SendKeys "%(qtmstv){ENTER}"                '在 VBE 窗口操作

Application.CommandBars("命令按钮名称").Position = msoBarFloating  '使[命令按钮]悬浮在表格中

   Application.CommandBars("命令按钮名称").Position = msoBarTop       '使[命令按钮]排列在工具栏中

ActiveSheet.protect Password:="wshzw"                         '为工作表保护加口令

ActiveSheet.Unprotect Password:="wshzw"                         '解除工作表保护

Activesheet.ProtectContents                                 '判断工作表是否处于保护状态

工作表的复制与命名

Sub wshzw()

   Dim i As Integer

   For i = 1 To 5

      Sheets("Sheet1").Copy After:=Sheets(1)  'Before/After 复制新表在 Sheets("Sheet1") 前/后

      ActiveSheet.Name = i & "月"             '为复制的新表命名

   Next i

   Sheets("Sheet1").Name = "总表"             '为 Sheets("Sheet1") 改名

End Sub

Application.EnableEvents = False       

      ......

Application.EnableEvents = True   '抑制事件连锁执行

Application.EnableEvents = False

ActiveWorkbook.Save     '抑制BeforeSave事件的发生

Application.EnableEvents = True     '抑制指定事件

Application.DisplayAlerts=False  '屏蔽确认提示 

 Application.ScreenUpdating = False

   .......

Application.ScreenUpdating = true    ' 冻结屏幕以加快程序运行

 

ActiveCell.CurrentRegion.Select                              '选择与活动单元格相连的区域

range("a2:a20").NumberFormatLocal = "00-00"                          '区域的格式化

ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row          '已用区域的最末行

ActiveSheet.Copy Before:=Sheets(1)                          '复制活动工作表到第一张工作表之前

range("a2:a20").FormulaHidden = True                           '工作表处于保护状态时隐藏部分单元格公式

 

FileDateTime("E:\My Documents\33.xls")

或

FileDateTime(thisworkbook.FullName)     '文件被创建或最后修改后的日期和时间

FileLen(thisworkbook.FullName) / 1024

或

FileLen("E:\My Documents\temp\33.xls") / 1024     '文件的长度(大小),单位是 KB

Application.AskToUpdateLinks = False                     '不询问是否更新链接,并自动更新链接

ActiveSheet.Hyperlinks.Delete                                   '删除活动工作表超链接

ActiveWorkbook.SaveLinkValues = False                        '不保存活动工作簿的外部链接值

ActiveSheet.PageSetup.CenterFooter = Range("k2").Value          '打印时设置自定义页脚

ActiveSheet.PageSetup.Orientation = xlLandscape                 '设置为横向打印

ActiveSheet.PageSetup.Orientation = xlPortrait                  '设置为纵向打印

Application.WindowState = xlMinimized    '最小化窗口

    Application.WindowState = xlNormal    '最大化窗口

Sub 删除工作表()

    Application.DisplayAlerts = False

    Sheet1.Delete

    Application.DisplayAlerts = True

End Sub

有删除就有添加

Sub 添加工作表()

    For i = 1 To 5

        Worksheets.Add.Name = i

    Next

End Sub

[A1:A20].AdvancedFilter xlFilterCopy, [B1], Unique:=True          '可去掉重复数据

[A2:C32].Replace What:="F", Replacement:="G"                     '指定范围内的查找与替换

Activesheet.AutoFilterMode = false                              '取消自动筛选

执行以下语句可有效缩小工作簿的大小，执行前请先看清每条语句的作用:

ActiveSheet.UsedRange.ClearComments             '清除活动工作表已使用范围所有批注

ActiveSheet.UsedRange.ClearFormats             '清除活动工作表已使用范围所有格式

ActiveSheet.UsedRange.Validation.Delete         '取消活动工作表已使用范围的数据有效性

ActiveSheet.Hyperlinks.Delete                   '删除活动工作表超链接

ActiveSheet.DrawingObjects.Delete               '删除活动工作表已使用范围的所有对象

ActiveSheet.UsedRange = ActiveSheet.UsedRange.Value      '取消活动工作表已使用范围的公式并保留值

还有：

Sub x()

   Dim myRange As String

   myRange = ActiveSheet.UsedRange.Address     '去除活动工作表无数据的行列

End Sub

ActiveWorkbook.FullName                          '当前窗口文件名与路径

Application.AltStartupPath= "E:\My\MyStart"      '替补启动目录路径

Application.AutoRecover.Path                     '返回/设置Excel存储"自动恢复"临时文件的完整路径

Application.DefaultFilePath                      '选项>常规中的默认工作目录

Application.Evaluate("=INFO(""directory"")")     '默认工作目录

Application.LibraryPath                          '返回库文件夹的路径

Application.NetworkTemplatesPath                 '返回保存模板的网络路径

Application.Path                                 '返回应用程序完整路径

Application.RecentFiles.Item(1).Path             '返回最近使用的某个文件路径,Item(1)=第一个文件

Application.StartupPath                          'Excel启动文件夹的路径

Application.TemplatesPath                        '返回模板所存储的本地路径

Application.UserLibraryPath                      '返回用户计算机上 COM 加载宏的安装路径

Debug.Print Application.PathSeparator            '路径分隔符 "\"

CurDir                                           '默认工作目录

Excel.Parent.DefaultFilePath                     '默认工作目录

ThisWorkbook.Path                                '返回当前工作薄的路径

dim mm(2,10)

Range("a1:b10")=mm              '可以将二维数组赋值给Range

Application.Dialogs(XLdialogsaveas).show     显示保存对话框

[SIZE=1]Sub x()

   Dim myRange As String

   myRange = ActiveSheet.UsedRange.Address     '去除活动工作表无数据的行列

End Sub

这相当于把新的已使用区域赋值给变量，效果等同于手工删除多余的列或行后立即保存;

来一个函数的

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'右边单元格反向显示活动单元格文本

If ActiveCell.Column < 256 Then ActiveCell.Offset(0, 1) = StrReverse(ActiveCell)

End Sub

想不到UsedRange还可以这样用，又学到了！有了这个就可以轻松取得当前Sheet的最末行和最末列号了：

Sub test()

Dim myRange As String

myRange = ActiveSheet.UsedRange.Address

Debug.Print "LastRow=" & Cells.SpecialCells(xlCellTypeLastCell).Row

Debug.Print "LastColumn=" & Cells.SpecialCells(xlCellTypeLastCell).Column

myRange = ""

End Sub

跟一帖：如上下相邻单元格数据相同则删除一个

Sub Yjue()

   Dim myCell As Range, NCell As Range        '定义

   Set myCell = ActiveSheet.Range("b2")       '把对象ActiveSheet.Range("b2")赋给变量myCell

   Do While Not IsEmpty(myCell)               '条件为True时执行 

      Set NCell = myCell.Offset(1, 0)         '把对象myCell的下一个单元格赋给变量NCell

      If NCell.Value = myCell.Value Then      '如上下相邻单元格数据相同,则望下执行

          myCell.Delete                       '删除myCell

      End If                                  '结束条件语句

      Set myCell = NCell                      '把变量NCell赋给变量myCell,等于在循环中把原myCell下移了一格

   Loop

End Sub

复制行高列宽与内容:

Sub Yjue()                      '过程的名称

   Sheet2.Rows("2:23").Copy     '复制行区域

   Sheet3.Select                '选择粘贴区域

   Range("A2").PasteSpecial Paste:=xlPasteColumnWidths   '粘贴类型

   ActiveSheet.Paste            '实施粘贴

   Application.CutCopyMode = False   '取消复制模式

End Sub

如整行为空白则删除整行:

Sub DelRow()

   Dim i As Integer, LastRow As Integer

   LastRow = ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell).Row  '把最后行的行号赋给变量

   For i = LastRow To 1 Step -1                                      '倒循环

      If Range("iv" & i).End(xlToLeft).Column = 1 And Range("a" & i) = "" Then 

         Range("a" & i).EntireRow.Delete                          '如整行为空白则删除整行

      End If

   Next i                                        

End Sub

T = Application.GetOpenFilename("Text Files (*.dat), *.dat")选择文件保存路径

通过依次赋色给单元格的例子，展示简单的 On Error GoTo Line1 用法：

Sub Yjue()                '过程名

   Dim i As Integer       '定义 i 为整型

   On Error GoTo Line1    '遇到错误跳转到 Line1

   For i = 0 To 65        '予设从 0 循环到 65

      Cells(i + 1, 2).Interior.ColorIndex = i  '依次赋色给第2列的单元格

      Cells(i + 1, 1) = i                      '依次给第1列的单元格标上色索引号

   Next i

   Exit Sub              '退出过程

Line1:                   '遇到错误跳转到这行继续执行

   MsgBox "默认颜色只有 " & i - 1 & "种。"    '提示对话框

End Sub                  '结束过程

通过显示或取消网格线，展示运算符“Not”应用的简单示例：

   Dim myLine As Boolean                     '定义变量myLine为布尔型

   With CommandButton1                         'With语句结构

      If .Caption = "取消网格线" Then             '如按钮上显示为"取消网格线"

         .Caption = "显示网格线"                  '改按钮上的字幕为"显示网格线"

         myLine = ActiveWindow.DisplayGridlines       '把活动窗口当前网格线的显示状态赋给变量

         ActiveWindow.DisplayGridlines = Not myLine     '进行逻辑否定运算

      Else               

         .Caption = "取消网格线"                        '否则按钮上显示为"取消网格线"

         ActiveWindow.DisplayGridlines = Not myLine     '进行逻辑否定运算

      End If

   End With                           '结束With语句结构

ActiveCell.Offset(, -1).Name = "hzw"                            '定义名称

ActiveCell.Precedents.Address                                   '被当前单元格所引用的区域地址

ActiveCell.Resize(0, 2).Select                                  '选定当前单元格并向右延伸二格

Activesheet.AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1 '显示自动筛选后的行数

有选择地删除指定区域内的单元格

点击按钮可选择性的删除[A1：A20]区域内含有[D1]中字样的单元格；再点击按钮可返回原样；

如果替换了[D1]中的字样，点击按钮后所删除[A1：A20]区域中的单元格亦会随着变化。

   With CommandButton1

      If .Caption = "删除单元格" Then       '如按钮显示的字符为:"删除单元格",

         .Caption = "反悔删除"              '则改为:"反悔删除"

         For i = 20 To 1 Step -1            '倒循环

            If Cells(i, 1) Like "*" & Range("d1") & "*" Then

               Cells(i, 1).Delete Shift:=xlUp     '如循环中发现某个单元格含有[D1]中字符,则删除该单元格

            End If

         Next i

      Else

         .Caption = "删除单元格"            '否则让按钮显示的字符为:"删除单元格"

         Range("a1:a20") = Range("f1:f20").Value   '把[F1:F20]赋给[A1:A20],为了可反复测试

      End If

   End With

下面换个话题，举一个限制鼠标只能在[B2:G60]以外的区域活动的例子：

   With ActiveSheet                      'With 语句,在一个单一对象上执行一系列的语句

      .Unprotect                         '解除没设密码的工作表保护 

      .Cells.Locked = False              '解除活动工作表中所有单元格的“锁定”

      .Range("b2:g60").Locked = True     '只锁定 [B2:G60] 区域

      .EnableSelection = xlUnlockedCells   '仅允许选定未被有效锁定的单元格

      .Protect                           '工作表保护(没设密码)

   End With                              'With 语句结束

一个复制数据后，只能粘贴数值的例子

Private Sub Worksheet_SelectionChange(ByVal T As Range)  '工作表SelectionChange事件

   On Error Resume Next                                  '忽略代码运行中的错误,并越过错误继续执行后面的语句

   If T.Column = 1 Then                                '如活动单元格为第一列时执行下面的语句

      Selection.PasteSpecial Paste:=xlPasteValues     '粘贴数值

      Application.CutCopyMode = False                 '立即清空剪贴板

   End If                                            'IF结构结束

End Sub                                              '本过程结束 

-----------------------------------------------------------

如何用VBA获得工作簿名称?

For Each wbk In Workbooks

    MsgBox wbk.Name

Next

Workbooks.Close  '关闭所有工作簿

Application.Quit '关闭所有工作簿

 

工作簿调用的问题

本人做了一个程序，里面自定义了工具菜单：

     如果程序打开后，调用了一个新的工作簿，当再次调用第二个新的工作簿时如何用vba编写一段代码，先保存退出调用的第一个工作簿，然后再打开第二个新的工作簿

Dim Wb As Workbook

Sub test()

Set Wb = Workbooks.Open("book2.xls")

End Sub

Sub test2()

Wb.Close savechanges:=True

Set Wb = Workbooks.Open("book5.xls")

End Sub

下面代码为何不能进行两工作簿中的工作之间的复制？(复制代码出现不支持此属性或方法的错误)

　Mybo = ActiveWorkbook.Name

    She = Sheets(1).Name

    Range("A1:B1").Select

    Selection.AutoFilter

    Range("B2").Select

    Selection.AutoFilter Field:=1, Criteria1:=">100", Operator:=xlAnd, _

        Criteria2:="<200"

    Windows(Mybo).Worksheets(She).Range("A1:K5000").Copy _

        Destination:=Windows(mybook).Worksheets("acfmis").Range("A1")