自用VBA常用语句\函数\子过程

以下是本人Wen98在VBA工作实践中，为方便查找，备忘性的积累了一些VBA常用的语句\函数\子过程，以提高自己一点工作效率。（仅供参考、引用）

获取名字:

    WorkbookName主表 = ActiveWorkbook.Name

    Sheet透视表 = ActiveSheet.Name

选定:

    Windows(WorkbookName主表).Activate

    Sheets("取数").Select

    Range("A1").Select

    Range("K1:M3").Select

单元格赋值:

    Range("A1")="Abc"

    [A1]="Abc"

    Cells(行, 列)="123.00"

单元格跨薄引用(不打开工作薄而提取数据):

='F:\负债业务日报\prg\[模板20.xls]金融资产'!F5:F5

或:

    Range("A28").FormulaArray = "=[模板20.xls]金融资产!D4:D4"

    Range("A28").Formula      = "=[模板20.xls]金融资产!D4:D4"

是否显示警告信息:

    Application.DisplayAlerts = False  'True= 显示警告信息

显示提示信息:

    MsgBox "包括完整路径的工作簿名称为：" & ThisWorkbook.FullName

选择是否提示:

If MsgBox("设为汇总的单元格是:" & Selection.Address & "  确定吗?", vbYesNo) = vbNo Then Exit Sub

关闭薄:

    Windows(Workbook表).Close

删除子表:

    Sheets("操作步骤").Delete  或:

    Sheets(Sheet透视表).Select

    ActiveWindow.SelectedSheets.Delete

删除行

    Rows("2:316").Select

    Application.CutCopyMode = False

    Selection.Delete Shift:=xlUp

    Range("A2").Select

删除单元格:

    Range("B5").Delete

对象的完整引用:

Windows("模板1.xls").Activate

Range("A28") = Application.Workbooks("模板20_表内数据转换2.xls").Sheets("操作步骤").Range("F7")

更简洁地:

[A28]=Workbooks("模板20.xls").Sheets("操作步骤").Range("F7")

复制单元格(带格式):

Sub Macro1()

    Range("A1:C3").Select

    Selection.Copy

    Range("C1").Select

    ActiveSheet.Paste

End Sub

同薄复制单元格(带格式)

Sub Macro_1()

    Range("A1").Copy Range("C1")

End Sub

同薄复制单元格区域(空白为边界)

Sub RngCopy()

    Range("A1").CurrentRegion.Copy Range("G1") 'G1应在当前活动工作表

或

    Windows("模板20.xls").Activate

    Worksheets("操作步骤").Range("F7").CurrentRegion.Copy Worksheets("发布0").Range("D9")

或  Sheets("操作步骤").Range("F7").CurrentRegion.Copy Sheets("发布0").Range("D9")

End Sub

同薄复制单元格,去掉多余的激活和选择

Range("A1").Copy Sheets("Sheet2").Range("B1")

通过数组读写单元内容(不带格式):

Sub RngArr()

    Dim arr As Variant               '定义变量

    arr = Range("A1:C3").Value       '将A1：C3单元格的内容存储到数组arr里

    Range("E1:G3").Value = arr       '将数组arr的数据写入E1:G3单元格区域

End Sub

实例:

    Dim arr As Variant

    Windows("模板20.xls").Activate

    arr = Sheets("金融资产").Range("D4:AX82").Value

    '

    Windows("模板1.xls").Activate

    Sheets("金融资产").Range("D4:AX82").Value = arr

全表复制粘贴:

    Windows(Workbook表).Activate

    Sheets("表1").Select

    Cells.Select '全选

    Selection.Copy

    Windows(WorkbookName主表).Activate

    Sheets("表2").Select

    Cells.Select

    ActiveSheet.Paste

    Windows(Workbook表).Close

复制值:

    Workbooks.Open Filename:="存款表.xls"

    Windows("模板20.xls").Activate

    Sheets("发布").Select

    Range("C4:H4").Select

    Range(Selection, Selection.End(xlDown)).Select  'Shift+Ctrl+下键

  '  Range(Selection, Selection.End(xlToRight)).Select   'Shift+Ctrl+右键

  '  Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select 'Ctrl+End 键

    Selection.Copy

    Windows("存款表.xls").Activate

    Sheets("人民币").Select

    Range("C4").Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False  '复制值

保存薄:

    ActiveWorkbook.Save 

新建薄并保存修改结果:(复制区域SUB,在下面）

    Workbooks.Add

    WorkbookName新薄 = ActiveWorkbook.Name

    Call 复制区域SUB((WorkbookName日报表), "发布3", "A1:CF82", (WorkbookName新薄), "Sheet1", "A1")

    Workbooks(WorkbookName新薄).Close SaveChanges:=True, Filename:=C_PRG路径 & "测试表.xls"

原名保存文件，不显示警告信息框

    Application.EnableEvents = False

    ActiveWorkbook.Save

    Application.EnableEvents = True

关闭不保存，不显示警告信息框

    Application.DisplayAlerts = False '不显示

    ThisWorkbook.Close

    Application.DisplayAlerts = True  '显示

是否显示屏幕变化

    Application.ScreenUpdating = False

    Application.ScreenUpdating = True

是否显示Excel界面

Application.Visible = False '不显示Excel界面 True 'False 

Application.Visible = True

打开文件:

    TXT_Name = Application.GetOpenFilename("文本文件(*.txt), *.txt") '获取文件

    Workbooks.Open Filename:=TXT_Name

    Workbooks.Open Filename:=C_PRG路径 & "模板5.XLS"

另一种:

    If MsgBox("[B1]单元内容应先设为读取的文件名, 准备好了吗?", vbYesNo) = vbNo Then 'Exit Sub

       XLS_Name = Application.GetOpenFilename("Excel文件(*.xls), *.xls")

       Range("B1") = XLS_Name

    Else

       XLS_Name = Range("B1") '读取的文件名

    End If

    Workbooks.Open Filename:=XLS_Name

    Workbook表名 = ActiveWorkbook.Name

总行数:

已用区域行数 = Sheets("基金取数").UsedRange.Rows.Count  '已用区域行数

已用区域列数 = Sheets("基金取数").UsedRange.Columns.Count  '已用区域行数

右下角地址 = Cells(已用区域行数, 已用区域列数).Address

MsgBox Range("A1:" & 右下角地址).Address  '区域地址

已用区域地址

MsgBox ActiveSheet.UsedRange.Address(0, 0) '已用区域地址

或:

已选定区域行数 = Selection.Rows.Count '已选定范围的行数

[B1] = 已用区域行数

或:

最后行号 = Range("B5").End(xlDown).Row   'B列最后行号,可用,B5下方不应有空单元格

最后列号 = Range("A4").End(xlToRight).Column

列名 = Columns(最后列号).Address  '得出如: $N$N

最后行号 = Cells(Rows.Count, 3).End(xlUp).Row  'C列最后行号,比较通用

相当于:

最后行号 = Range("C65536").End(xlUp).Row   '最后行号,可用,V2003

获取行列坐标:

列 = Selection.Column

行 = Selection.Row

或

列 = ActiveCell.Column

行 = ActiveCell.Row

设置公式(填充):(关联的透视表最后列并不固定)

Sheets("透视表").Select

最后列号 = Range("A4").End(xlToRight).Column   '最后列号

列名 = Columns(最后列号).Address

Sheets("金额").Select

最后行号 = Range("C4").End(xlDown).Row   '最后行号

Range("E5").Select

ActiveCell.Formula = "=SUMIF(透视表!A:A,B:B,透视表!" & 列名 & ")"  '设置公式

Selection.AutoFill Destination:=Range("E5:E" & 最后行号) '填充

消除表内容:

ActiveSheet.Cells.Clear

消除内容:

Selection.ClearContents

把每个数字转换成9位字符，不足者前面添0, 在单元格输入公式:

=REPT(0,9-LEN(A23)) &A23

用代码简化输入(在[代码]工作表中有A列代码,B列名称)

在工作表A列输入代码后,在B列得出名称,B2单元格输入公式:

=IF(ISERROR(VLOOKUP(A2,代码!A:B,2,FALSE)),"",VLOOKUP(A2,代码!A:B,2,FALSE))

冻结窗口

    Range("C4").Select

    ActiveWindow.FreezePanes = True '冻结窗口,C4起

查找包括X的单元格

Cells.Find(what:="X").Activate

列 = ActiveCell.Column

行 = ActiveCell.Row

或:

行号 = Cells.Find(what:="X").Row

列号 = Cells.Find(what:="X").Column

通过短名(简称)求长名代码

=LOOKUP(0,0*FIND(简称!$A$2:$A$112,A3),简称!$B$2:$B$112)

其中:[简称!$A$2:$A$112] 为简称,[简称!$B$2:$B$112] 为行号,A3为网点全名

==================================================================================================

Sub 复制表1已用区域值到表2A1(源薄名 As String, 源表名 As String, 目标薄名 As String, 目标表名 As String)

Windows(源薄名).Activate

With Sheets(源表名).UsedRange '整个已用区域,自动计算区域大小

     Windows(目标薄名).Activate

     Sheets(目标表名).[A1].Resize(.Rows.Count, .Columns.Count) = .Value

End With

End Sub

==================================================================================================

Sub 复制表1区域值到表2(源薄名 As String, 源表名 As String, 源区域 As String, 目标薄名 As String, 目标表名 As String, 目标左上格 As String)

'自动计算区域大小,目标区域只需定位左上角单元格

Windows(源薄名).Activate

Sheets(源表名).Select

Range(源区域).Select

With Selection '已选定区域

     Windows(目标薄名).Activate

     Sheets(目标表名).Range(目标左上格).Resize(.Rows.Count, .Columns.Count) = .Value

End With

End Sub

==================================================================================================

Sub 数组方式复制整表(源路径薄名 As String, 目标薄名 As String, 目标表名 As String) '比较快

'SUB:源薄名调用前已打开,复制后关闭 复制值'

'要求: 目标区域只需定位左上角单元格

'调用: Call 数组方式复制整表(Worksheets("操作步骤").Range("G9").Value, (WorkbookName主表), "表内人民币")

    Dim arr As Variant

    Workbooks.Open Filename:=源路径薄名 'Worksheets("操作步骤").Range("G9").Value

    源薄名 = ActiveWorkbook.Name

    区域 = ActiveSheet.UsedRange.Address(0, 0) '已用区域地址

    arr = Range(区域).Value

    ActiveWorkbook.Close '关闭源薄

    

    Windows(目标薄名).Activate

    Sheets(目标表名).Range(区域) = arr

    

End Sub

==================================================================================================

Sub 数组方式复制区域值SUB(源薄名 As String, 源表名 As String, 源区域 As String, 目标薄名 As String, 目标表名 As String, 目标区域 As String)

'SUB:源薄名调用前已打开不关闭 复制值'

'要求: 目标区域 大小 = 源区域 大小

'调用: Call 数组方式复制区域值SUB((Workbook模板20), "金融资产", "D4:AX82", (WorkbookName日报表), "金融资产", "D4:AX82")

    Dim arr As Variant

    Windows(源薄名).Activate

    

    arr = Sheets(源表名).Range(源区域).Value

    Windows(目标薄名).Activate

    Sheets(目标表名).Range(目标区域).Value = arr

    

End Sub

==================================================================================================

Sub 数组方式复制区域值SUB2(源薄名 As String, 源表名 As String, 源区域 As String, 目标薄名 As String, 目标表名 As String, 目标左上格 As String)

'SUB:源薄名调用前已打开不关闭 复制值'

'要求: '自动计算区域大小,目标区域只需定位左上角单元格

'调用: Call 数组方式复制区域值SUB2((Workbook模板20), "金融资产", "D4:AX82", (WorkbookName日报表), "金融资产", "D4")

    Dim arr As Variant

    Windows(源薄名).Activate

    Sheets(源表名).Select

    Range(源区域).Select

    区域高 = Selection.Rows.Count

    区域宽 = Selection.Columns.Count

    arr = Sheets(源表名).Range(源区域).Value

    

    Windows(目标薄名).Activate

    Sheets(目标表名).Range(目标左上格).Resize(区域高, 区域宽) = arr

    

    'MsgBox Sheets(目标表名).Range(目标左上格).Resize(区域高, 区域宽).Address

    

End Sub

==================================================================================================

Sub 复制整表SUB(源薄名 As String, 源表名 As String, 目标薄名 As String, 目标表名 As String)

  'Application.DisplayAlerts = False  'True 显示警告信息

    Workbooks.Open Filename:=源薄名 'Worksheets("操作步骤").Range("G9").Value

    Workbook表 = ActiveWorkbook.Name

    Sheets(源表名).Select

    Cells.Select

    Selection.Copy

    

    Windows(目标薄名).Activate

    Sheets(目标表名).Select

    Cells.Select

    ActiveSheet.Paste

    'Windows(Workbook表).Close

  'Application.DisplayAlerts = True 'False  'True 显示警告信息

   

End Sub

================================================================================

Sub 复制区域SUB(源薄名 As String, 源表名 As String, 源区域 As String, 目标薄名 As String, 目标表名 As String, 目标区域 As String)

    

    Windows(源薄名).Activate

    Sheets(源表名).Select

    Range(源区域).Select

    Range(Selection, Selection.End(xlDown)).Select

    Selection.Copy

    

    Windows(目标薄名).Activate

    Sheets(目标表名).Select

    Range(目标区域).Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False  '复制值

End Sub

================================================================================

文件是否存在

Sub TestFile()

    MsgBox "下面将判断当前目录下是否存在“员工花名册.xls”工作薄文件。"

    Dim fil As String                                          '定义变量

    fil = ThisWorkbook.Path & "\员工花名册.xls"

    If Len(Dir(fil)) > 0 Then                                  '用Dir函数判断fil指代的文件是否存在

        MsgBox "工作薄已存在!"

    Else

        MsgBox "工作薄不存在!"

    End If

End Sub

================================================================================

Function 工作表是否存在(表名 As String) As Boolean '自定义函数: 工作表是否存在

    Dim i As Long

    For i = Worksheets.Count To 1 Step -1

        If Worksheets(i).Name = 表名 Then

            Exit For

        End If

    Next

    工作表是否存在 = IIf(i = 0, False, True) '如果i = 0工作表未找到

End Function

调用:

    If 工作表是否存在((表名)) = False Then

       Sheets.Add(after:=Sheets("成表")).Name = 表名   '"成表"之后插入

    End If

=====================================================================================

Function 工作簿是否打开(sWkbName As String) As Boolean '自定义函数: 工作簿是否打开

'如果要判断一个指定的工作簿是否打开，可以将下面的VBA代码放入标准模块中，然后在子过程中进行调用。

'如果目标工作簿已打开则返回TRUE，否则返回FALSE

    Dim i As Long

    For i = Workbooks.Count To 1 Step -1

        If Workbooks(i).Name = sWkbName Then

            Exit For

        End If

    Next

    

    工作簿是否打开 = IIf(i = 0, False, True) '如果i = 0工作簿未找到

End Function

================================================================================

Sub 返回模板1()

    If 工作簿是否打开("模板1.xls") = False Then

        Workbooks.Open Filename:="F:\报表\日报\prg\模板1.xls"  '打开表

    End If

    Windows("模板1.xls").Activate

End Sub

=====================================================================================

Sub 打开或隐藏列()

    Sheets("变动表").Select

    Columns("V:AO").Select

    Selection.ColumnWidth = IIf(Selection.ColumnWidth > 0, 0, 12)

End Sub

=======================================================

Sub 打开或隐藏无关表()

    Worksheets("过渡表").Visible = Not Worksheets("过渡表").Visible   'False 'True

    Worksheets("汇总单位").Visible = Not Worksheets("汇总单位").Visible   'False 'True

End Sub

=======================================================

Sub 另存并关闭()

    ActiveWorkbook.Close SaveChanges:=True, Filename:="test.xls"

End Sub

=======================================================

标题行输入:

    Dim myArray As Variant

    Dim i As Integer

    ActiveSheet.Cells.Clear

    '准备数据

    myArray = Array("AAA", "BBB", 200, 500, "2006-7-12")

    For i = LBound(myArray) To UBound(myArray)

        Cells(i + 1, 1) = myArray(i)

    Next i

=======================================================

Sub 设置片区汇总公式()

'用法: 先定位"分行汇总的单元格", 再运行本宏, 即可自动设置片区汇总公式

'分行汇总在最上面,片区汇总在网点下方(片区包含若干网点)

'MsgBox ActiveCell.Column

If MsgBox("设为合计汇总的单元格是:" & ActiveCell.Address & "  确定吗?", vbYesNo) = vbNo Then Exit Sub

列 = ActiveCell.Column  '自动得出

行0 = ActiveCell.Row    '自动得出

Dim A As Variant

'片区个数 = 14

A = Array(10, 5, 3, 3, 4, 1, 2, 3, 2, 2, 9, 6, 6, 6) '各片区包含的网点个数(行)

行 = 行0

总计 = "=SUM("

For i = 0 To UBound(A) '确定数组的指定维的最大可用下标。

    含 = A(i)

    行 = 行 + 含 + 1

    'Range(列 & 行).Select

    Cells(行, 列).Select '可行

    ActiveCell.FormulaR1C1 = "=SUM(R[-" & 含 & "]C:R[-1]C)"

    总计 = 总计 & "R[" & 行 - 行0 & "]C,"

Next

Cells(行0, 列).Select '可行

ActiveCell.FormulaR1C1 = 总计 & ")"   '总计

End Sub

=========================================================

Sub 匹配简称获取行号Find()

N行数1 = Sheets("行名简称").UsedRange.Rows.Count    '行名简称

N行数2 = Sheets("操作表").UsedRange.Rows.Count    '操作表

'清除B列

Sheets("操作表").Select

Range("B2:B" & N行数2).Select

Selection.ClearContents

Dim W行名简称 As Worksheet

Set W行名简称 = Worksheets("行名简称")

Dim W操作表 As Worksheet

Set W操作表 = Worksheets("操作表")

For i = 2 To N行数1    '行名简称

    C行名简称 = Trim(W行名简称.Cells(i, 4))

    C代号 = W行名简称.Cells(i, 6)  '归并行号

    

 If Len(C行名简称) > 0 Then

    For j = 2 To N行数2  '操作表

        

        With W操作表.Cells(j, 1)

             Set YN = .Find(C行名简称)

        End With

        If Not YN Is Nothing Then

           W操作表.Cells(j, 2) = C代号

        End If

     

    Next j

  End If

Next i

MsgBox "OK !"

End Sub

===========================================================================

问题一：在VBA代码中，如何引用当前工作表中的单个单元格(例如引用单元格C3)？

回答：可以使用下面列举的任一方式对当前工作表中的单元格(C3)进行引用。

(1) Range("C3")

(2) [C3]

(3) Cells(3, 3)

(4) Cells(3, "C")

(5) Range("C4").Offset(-1)

Range("D3").Offset(, -1)

Range("A1").Offset(2, 2)

(6) 若C3为当前单元格，则可使用：ActiveCell

(7) 若将C3单元格命名为“Range1”，则可使用：Range("Range1")或[Range1]

(8) Cells(4, 3).Offset(-1)

(9) Range("A1").Range("C3")

**************************************************************************************************

Sub 读写机构号()

'

' 宏由 gd-wenbirong 录制，时间: 2012-12-24

'

' (13180-BEPD0010)  往账清单.txt

'

'用Excel打开往账清单.txt,按空格符分列,运行这个宏,

'排序,删除无用行,透视表,关联网点名,OK

'

C机构号 = ""

For i = 1 To 1832

 If Left(Cells(i, 1), 4) = "机构号:" Then

    C机构号 = Mid(Cells(i, 1), 6, 5) '读

    'MsgBox C机构号

 End If

    Cells(i, 14) = C机构号 '写

Next i

End Sub

=======================================

Sub 基金透视表()

'

' Macro4 Macro

' 宏由 gd-wenbirong 录制，时间: 2012-12-4

'

'

    Sheets("基金取数").Select

    有效行 = Sheets("基金取数").UsedRange.Rows.Count  '已用区域行数

    Range("H1") = 有效行   '通过H1单元过渡

    ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _

        "基金取数!R1C1:R" & Range("H1") & "C7").CreatePivotTable TableDestination:="", TableName:= _

        "数据透视表1", DefaultVersion:=xlPivotTableVersion10

    ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3, 1)

    ActiveSheet.Cells(3, 1).Select

    ActiveWorkbook.ShowPivotTableFieldList = True

    With ActiveSheet.PivotTables("数据透视表1").PivotFields("资金账户开户机构")

        .Orientation = xlRowField

        .Position = 1

    End With

    With ActiveSheet.PivotTables("数据透视表1").PivotFields("基金类型")

        .Orientation = xlColumnField

        .Position = 1

    End With

    ActiveSheet.PivotTables("数据透视表1").AddDataField ActiveSheet.PivotTables("数据透视表1" _

        ).PivotFields("余额（份数）"), "求和项:余额（份数）", xlSum

    Application.CommandBars("PivotTable").Visible = False

    ActiveWorkbook.ShowPivotTableFieldList = False

    Sheet透视表名 = ActiveSheet.Name

    Cells.Select 'copy to "基金透视表"

    Selection.Copy

    Sheets("基金透视表").Select

    Cells.Select

    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _

        :=False, Transpose:=False

    

    有效行 = Sheets("基金透视表").UsedRange.Rows.Count  '已用区域行数

    Range("Q4") = 有效行   '通过P4单元过渡

    Range("Q5").Select

    ActiveCell.FormulaR1C1 = "=RC[-1]-RC[-4]-RC[-3]"  '减去: -M列(12 中银理财) -N列(13 信托)

    Selection.AutoFill Destination:=Range("Q5:Q" & Range("Q4"))

    'Range("Q5:P" & Range("Q4")).Select

    Range("Q4") = "纯基金" '增加列

    

    Sheets(Sheet透视表名).Select

    Application.DisplayAlerts = False  'True 显示警告信息

    ActiveWindow.SelectedSheets.Delete

    Application.DisplayAlerts = True  'True 显示警告信息

    'Application.CutCopyMode = False

    Sheets("基金透视表").Select

End Sub

===========================================================================

Sub test运行时间()

Application.ScreenUpdating = False '是否显示屏幕变化

xls1 = "模板1.xls"

xls2 = "模板20.xls"

tim = Timer

For i = 1 To 100

Call 复制表1区域值到表2((xls2), "金融资产", "D4:AX82", (xls1), "金融资产", "D4")    'test 可用

Next

MsgBox Format(Timer - tim, "0.00") & "秒"

tim = Timer

For i = 1 To 100

Call 数组方式复制区域值SUB((xls2), "金融资产", "D4:AX82", (xls1), "金融资产", "D4:AX82")    'test 较快

Next

MsgBox Format(Timer - tim, "0.00") & "秒"

Application.ScreenUpdating = True

End Sub