编程常用代码

编程常用代码

Excel2007启用宏：OFFICE按钮→选项→信任中心→信任中心设置→宏设置

代码里可以命名名称，比如 = "data1" ，然后在公式中使用它

"7777" '在立即窗口中显示

Environ("Computername") '计算机名

Environ("userprofile") ‘ 桌面路径

n="XXXXX" '在显示文件名的地方显示XXXXX

Windows().Visible = False '隐藏excel主窗口[文件名]

-------

文件和文件夹

当前文件夹的名称：CurDir

更改文件或文件夹的名称：（Name 原文件 As 新文件）

检查文件或文件夹是否存在：m=Dir(文件,Nomal) m=Dir(文件夹,Folder)Directory

创建文件夹（MkDir "D：文件夹名"）

f = Dir("D:省份分表", vbDirectory) '判断是否已经存在

If f = "" Then MkDir ("D:省份分表") '如果不存在就建立

删除文件：（Kill "D：文件夹名成品.xls"

删除空文夹：（RmDir "D：文件夹名"）

---------

复制文件：（FileCopy）

For i = 101 To 10000

FileCopy "D:迅雷.txt", "D:文件夹名" & i & "迅雷.txt"

Next

With arch

.Filename = "*.*"

.LookIn = & "分表"

.Execute

k = . '文件夹中的文件个数

End With

Sub 生成目录() '有子文件夹也查到

Set fs = arch

With fs

.LookIn = "D:暂用" '设置要查找的起始目录

.Filename = "*.*"

.SearchSubFolders = True '是否查找子目录

.Execute '根据上面的设置执行查找

For i = 1 To . '遍历文件

a = Dir(.FoundFiles(i))

Cells(i + 1, 3) = a

Next i

End With

End Sub

Shell " " & k & "生成的表", vbMaximizedFocus '展开文件夹

Sub 动态读取指定文件夹名()

On Error Resume Next

Dim stMedd As String

stMedd = "请选择文件目录："

Set obMapp = CreateObject("ation").BrowseForFolder(0, stMedd, &H1)

If Not obMapp Is Nothing Then

Directory = & "" '文件夹名

[G1].Value = Directory

Else

Exit Sub

End If

Call ist

End Sub

变量

模块级变量的声明格式Public Directory

Dim x As Integer '声明变量

Byte (0到255的整数) Integer % (-32768+32768) Date (日期) String $ (65400个字符) Decimal (小数)

Long & Single ! Currency @

Format(32, "0000") ‘Format格式结果为：0032

Dim Arr()

数组

ReDim Preserve Arr(1 To r) ‘声明动态数组

Array函数 ose ‘转置

数组下限LBound(Arr)=0 ，数组上限 UBound(Arr)=4

Erase arr ’清空数组

IsArray ’指出变量是否为一个数组

If (Arr)>0 Then '判断数组不为空

Range("A1:D1") = Array("'1001", "现金", 300000, Date) '在一行多列中依次输入不同数据

Range("A1:A4") = ose(Array("1001", "现金", 300000, Date)) 在一列多行中次输入不同数

Sub 字典 ()

r = ("A65536").End(xlUp).Row '最后行数

Set w = CreateObject("nary")

For i = 2 To r

b = (i, 2)

c = (i, 3)

If Not (b & c) Then

w(b & c) = 1

Else

W(b & c) = W(b & c) + 1

End If

Next

[A2].Resize(, 1) = ose()

[B2].Resize(, 1) = ose()

End Sub

Sub 用字典筛选多列()

r = Range("A65536").End(xlUp).Row '最后行数

Set w = CreateObject("nary")

For i = 2 To r

If Cells(i, 6) > 70 Then '语文分数为条件

w(Range(Cells(i, 1), Cells(i, 12))) = 1 '数据一行多列载入字典

End If

Next i

[N2].Resize(, 12) = ose(ose()) '两次转置写入单元格

End Sub

If "dfg" Like "*f*

" Then 判断字符串包含关系可用通配符

For Each st In Worksheets

With Chr(10) Exit For step 步长 ElseIf Else Do While … Loop

Updating = False '禁用刷新

yStatusBar = False '禁用状态显示

ation = xlCalculationManual '手动重算

Events = False '禁用触发事件

yPageBreaks = False '禁用新版本

Updating = true '启用刷新

yStatusBar = true'显示状态

Events = true '启用触发事件

ation = xlAutomatic '自动重算

yPageBreaks = true '启用新版本

InNewWorkbook = 1 '设置工作簿内的工作表数

ys "%{down}" '自动打开数据有效性列表

Workbooks("学习.xls").Worksheets("Sheet1").Range("A4").ClearContents '从文件到单元格

Cells(4, 1) Rang("A4") [A4] '单元格

Range("H3").Select '选定单元格

Range("A65536").End(xlUp) '最后行单元数据

x=Range("A65536").End(xlUp).Row '行数

x = Range("e2").End(xlDown).Row ''向下查找

Range("IV1").End(xlToLeft) '最后列单元数据

Range("IV1").End(xlToLeft).Column '列数

工作表使用区域的单元格

a = ().Row '格式最后行

b = ().Column '格式最后列

Cells(a, b) '最后一个单元格（不一定有数据）

(Cells(1, 1), Cells(a, b)) '数据最大区间起于A1单元格，止于最右下角单元格

f= Replace(mid(Cells(100,103).Address,2,2),"$","") ' 由列数得到列标CY

("*", , , , , 2).Row ' 工作表使用的有数据行数

("*", , , , , 2) .Column ' 工作表使用的有数据列数

IsNumeric判断数值

'选定表1中使用的区域，如果要向下或右移在UsedRange.后加进offset(1,2)

Range("a1").Copy Range("B1") ' 将A1单元数值（公式）和格式值复制到sheet3 B1中

注：Range("a1")不能用Cells()替代

Range("B1").Value = Range("a1").Value '将A1单元数值复制到sheet3 B1中

Range("C4:E7").Clear '清除格式和内容

Range("D4:E6").ClearContents '清除内容

sLocal ' 返回屏幕上可以看到的区域

[a3].Value = Trim([a3].Value) '删除空格 删左边Ltrim 删右边RTrim

[a:a].Replace "A", "" '将A列的“A”替换成空 单元格匹配LookAt:=xlWhole

TUTE([A1]," ","") ‘清除空格

Range("B2").Offset(1, 2).Select '以B2为基点，向下移1行，向右移2列

(6, 9).Select '得到一个6行9列的区域

Range("S1:S28").TextToColumns DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(2, 1))

只分出第1、2个字符

Range("B3:B" & + 2).TextToColumns , Other:=True, OtherChar:="/"

‘分列

[a:b].AdvancedFilter 2, [c1:c2], [g1] '高级筛选最简代码数据区间[a:b] 条件[c1:c2] 存放位置[g1]

Sheet1.[a:a].AdvancedFilter 2, "", [b5], Unique:=True 'Unique:=True (取不重复值)

[A1:D11].AdvancedFilter 2, , [E1], 1 '高级筛提取不重复值数据区间[A1:D11] 存放位置[E1]

MsgBox "行数为：" & & Chr(10) & "列数为：" & '当前行列数

Chr(10)：空行

公式

ClearContents－仅清除单元格或单元格区域内的数据

ClearFormats－仅清除格式

Range("A1").NumberFormat '读出A1格式

Range("A1").Formula '读出A1中的公式

Range("D2").FormulaArray = "=SUM((A2:A6)*1）" '先在D2中输入数组公式

Range("D2").Copy Range("D3:D9,E2:E9,F2:F9") '复制、粘贴公式（区间连续或不连续，但不能包括D2）

a = Range("e2").Formula ' 将E2中的普通公式填充到当前区域

For m = 2 To y '宏中动态引用公式（不适用于数组公式）

Range("m" & m) = Evaluate("SUMPRODUCT((sheet1!A2:A" & x & "=sheet2!A" & m & ")*(sheet1!B2:B" & x

& "=sheet2!B" & m & ")*(sheet1!L2:L" & x & ">sheet2!L" & m & "))") + 1

Find方法的语法

<单元格区域>.Find (要查找的数据，，[数据类型]，[XlWhole或者xlPart，用来指定所查找的数据是与单元格内容完全匹配还是部分匹配，默认值为xlPart])

Sub 由值查行列号() ‘Find方法

Set r = Range("a1:b12").Find([j6],,, XlWhole) ‘对占用内存较多的对象变量，不要时要记住set=nothing

On Error Resume Next ‘容错 r = Empty（出错）

[K6] = '行号

[L6] = '列号

[m6] = s '单元格

Set r=nothing ‘置空对象

End Sub

Sub 数组查找()

Dim Arr()

x = ("A65536").End(xlUp).Row '行数

y = Range("A65536").End(xlUp).Row '行数

ReDim Preserve Arr(1 To y)

For i = 1 To y

On Error Resume Next '容错

b = Cells(i, 1)

Set r = ("a1:a" & x).Find(b, , , xlWhole)

If r = Empty Then 'Empty（出错）

Arr(i) = ""

Else

Arr(i) = (, 2)

End If

Next

[B1].Resize(y, 1) = ose(Arr)

End Sub

MATCH函数方法用于取得关键字的行数或列数

If IsNumeric((Cells(i, 1), .Range("B1:B" & r), 0)) Then

' 关键字不存在时会出错，上句不可少

m = (Cells(i, 1), .Range("B1:B" & r), 0) ' 行数

Sub 查找()

Updating = False '禁用刷新

With Sheets("资料表")

x = .Range("R65536").End(xlUp).Row

y = Range("F65536").End(xlUp).Row

For i = 2 To y

If IsNumeric((Cells(i, 6), .Range("R1:R" & x), 0)) Then

m = (Cells(i, 6), .Range("R1:R" & x), 0) ' 行数

.Range("N" & m & ":Q" & m).Copy Cells(i, 1)

End If

Next

End With

End Sub

x = [a1] '多条件语句

If x < 100 And x > 80 Then '第1句

[d5] = "好"

ElseIf x = 0 Then '第2句

[d5] = "最好"

Else '其他

[d5] = "错误"

End If

Select Case '按条件选择执行宏

Case Is > 1

删除工作表

插入新表

Case Is = 1

插入新表

Case Else

End Select

End Sub

(或CurDir) '当前工作簿地址

当前工作簿名称

me '当前工作簿路径和名称

'当前工作表名

Area = "B4:H12" '限制表中显示的区间

Private Sub Workbook_Open() '打开工作簿时执行

Savechanges:=True '不保存关闭当前工作簿

Private Sub Workbook_BeforeClose(Cancel As Boolean) '关闭工作簿时执行

'不保存退出

Workbooks(1).Close SaveChanges:=False ‘不保存关闭指定工作簿

'保存退出

Filename:= & "档案.xls", Password:="1234"

'如文件：档案，有密码1234 用这句代码可以打开excel 模板文件类型：xlt

For Each c In '隐藏[显示]定义名

e = False

Next c

MsgBox "宏" & Chr(13) & Chr(13) & "真难学啊！", , "感叹" '消息框格式Chr(13) 换行

InputBox函数：格式如下，第一项为必须外，其余为可选项,可以省略不写，XY坐标为在窗体上的准确位置。当用户点取消时，返回一个空的字符串(" ")。为了省略某些位置参数，必须加入相应的逗号分界符。

InputBox("对话框中的提示信息","对话框的标题","缺省的返回值"，X坐标，Y坐标)

X坐标和Y坐标当你需要为InputBox窗口指定在屏幕中的位置时用的，单位为象素，一般省略不写。

Val 文本变数值

Sub 选定单元格() ‘InputBox方法 ctive = True

Dim a As Range

On Error GoTo VeryEnd '[当按下“取消”按钮时，程序会出错，加上此句与后边VeryEnd:相对应，这样当出错时，程序结束 或ctive = True]

Set a = ox(prompt:="使用鼠标选择单元格区域：", Title:="格式化区域", Type:=8)

Format = "0.00" '单元格式：两位数

VeryEnd:

End Sub

Sub 合并单元格()

yAlerts = False '合并时不提问

For h = Range("A65536").End(xlUp).Row To 4 Step -1

If Cells(h, 10) = Cells(h + 1, 10) Then Range(Cells(h, 10), Cells(h + 1, 10)).Merge

Next

End Sub

Range("B4:D5").Select '合并居中

With Selection

.HorizontalAlignment = xlCenter

.VerticalAlignment = xlCenter

.ReadingOrder = xlContext

End With

' (合并单元格)

――――

[a1:g18].yle = 1 '加细边框

Range("A6:F10").yle = xlContinuous '加细边框

Range("A6:F10").BorderAround Weight:=xlThick '加边粗框

Range("A6:F10").yle = xlNone '去边框

――――

Sub 循环 () ‘Exit For 跳出循环end

x = Range("A65536").End(xlUp).Row '声明最后一行的行号

For h = 5 To x '从第1行到最后一行 step 步长

If Cells(h, 1) > 0 Then '判断、赋值

Cells(h, 2) = "大于零"

ElseIf Cells(h, 1) = 0 Then

Cells(h, 2) = "等于零"

ElseIf Cells(h, 1) < 0 Then

Cells(h, 2) = "小于零"

End If

Next h

End Sub

Sub 行列多循环()

a = [p2] - 1

For b = 1 To 11 Step 2

For c = 4 To 28

a = a + 1 '此句决定其数据不同

If a > [p3] Then Exit Sub '此句在达到最大值时退出循环

Cells(c, b) = a

Next c, b

End Sub

Private Sub Worksheet_Change(ByVal Target As Range) '单元格触发事件[输入即保存]

If Target <> "" Then '没有选定或输入字符不触发

'保存

End If

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) '鼠标选定触发

ndex = 0 '整个工作表无色

ndex = 35 '鼠标选定区域变色

End Sub

sheets("数据").Visible=xlSheetVeryHidden ‘隐藏工作表

sheets("数据").Visible=xlSheetVisible ‘显示工作表

= "数据" '插入名为数据的工作表

Sub 删除工作表() '只保留最左边那一个

Dim mysheet As Worksheet

If > 1 Then '有2个以上才删除

Worksheets(2).Select

yAlerts = False '删除表时不提问

For Each mysheet In Worksheets

Next mysheet

End If

End Sub

Sub 工作表合并 () '当前表、目录表和统计表不合并，其他表都合并

For Each st In Worksheets

If <> And <> "目录" And <> "统计" Then

(2, 0).Copy [a65536].End(xlUp).Offset(1, 0)

End If

Next

End Sub

Sub 生成目录()

Dim myPath As String

Dim myFileName As String

Dim i As Long

myPath = & "" '指定文件夹

myFileName = Dir(myPath, 0)

i = 0

Do While Len(myFileName) > 0

Cells(i + 1, 1) = Left(myFileName, Len(myFileName) - 4) '生成目录

myFileName = Dir()

i = i + 1

Loop

End Sub

Sub 批量修改文件名()

aaa =

h = 2

Do

oldname = Cells(h, 2)

newname = Cells(h, 1)

If oldname = Empty Then Exit Do

On Error Resume Next ‘出错时继续下一步 m=[错误号数,m=0,无错]

Name aaa & "" & oldname & ".xls" As aaa & "" & newname & ".xls" '实际用时就改一下文件后辍名

On Error GoTo 0

h = h + 1

Loop

End Sub

Sub 删除工作簿()

On Error Resume Next

Kill "D: "

End Sub

Sub 列出工作表名() '用到循环

For k = 1 To '工作表总数

Cells(k, 1) = Sheets(k).Name '工作表名存放位置Cells(k, 1) 第K个工作表名Sheets(k).Name

Next

End Sub

Sub 删除所有定义名称()

Dim n As Name

For Each n In

Next

MsgBox "所有名称已被删除！"

End Sub

Sub 计算运行时间()

Dim Start As Double, Finish As Double

Start = Timer '开始时间

'--------------------------------------

Worksheets(1).Range("H1:H40000").Replace "4", "4.5" '过程

'--------------------------------------

Finish = Timer '结束时间

MsgBox "本次运行的时间是：" & Finish - Start & "秒"

End Sub

Sub 导入表2并填色()

Sheets(1).Rows("13:22").Copy Sheets(2).Rows("2:11") '表1复制到表2（全部）

Sheets(2).Rows("2:11"). = "黑体" '将这个范围字体格式为“黑体”

Sheet(2).Range("a3").ndex = 6 '在A3单元中填进黄色

End Sub

Sub 判断工作表是否存在()

Dim sh As Worksheet

Dim d$

d = Day([r5]) & "日" '新表名来源

For Each sh In Worksheets

If = d Then n = n + 1

Next

If n = 0 Then '不存在

after:=Sheets() '在所有表最右边插入一表

= d '新表名为 d

ElseIf n > 0 Then '表存在

[m26] = "SSSSS" '在M26中输入字母

End If

End Sub

Sub判断工作表是否存在()

r = InputBox("", "")

For h = 1 To

If r = Sheets(h).Name Then

MsgBox r & "存在"

End

End If

Next

MsgBox r & "不存在"

End Sub

Sub 汇总()

Updating = False

x = ("A65536").End(xlUp).Row '最后行数AVG 算术平均数

With CreateObject("tion")

.Open "provider=.4.0;extended properties='Excel 8.0;hdr=no;';data

me

[p4].CopyFromRecordset .Execute("select f1 from[sheet1$a3:n" & x & "] group by f1")

.Close

source=" &

End With

Updating = true

End Sub ‘数据库无标题：hdr=no数据库有标题：hdr=yes

'条件取不重复值where f4>=3 group by f5

Sub 提取多列不重复值()

Dim i%, c

i = Sheet1.[a65536].End(xlUp).Row

For Each c In ("b3:d" & i) 数据区"b3:d" & i

If f(s(2), c) = 0 Then

Sheet2.[b65536].End(xlUp).Offset(1, 0) = c

End If

Next c

End Sub

With [J3:K257]

.HorizontalAlignment = xlCenter '居中

.VerticalAlignment = xlCenter

End With

Sub 更改透视表字段为求和()

For h = 2 To 21

m = Cells(4, h).Value

Cells(4, h).Select

ables("数据透视表1").PivotFields(m).Function = xlSum

Next

End Sub

Sub 错误处理()

Dim I As Long

On Error Resume Next ' 指定发生错误时不处理，直接运行下一条语句

I = "A1" ' 发生错误,由于已经指定了发生错误时不处理，故Err对象立即返回直接运行下一条语句。

"被忽略的错误,错误代码：" & & " 错误信息" & ption & " 错误源：" &

& " 当前I的值=" & I

' 清空所有错误记录

On Error GoTo ERROR1 ' 指定下面的错误发生时直接跳转至Error1标号处

I = 2147483648# ' 发生错误,由于指定了跳转，故直接转至Error1，而不会再执行下面的语句

I = 100

"程序正常返回，当前I的值=" & I

Exit Sub

ERROR1:

"发生错误,错误代码：" & & " 错误信息" & ption & " 错误源：" &

& " 当前I的值=" & I

End Sub

Sub 调出窗体()

0

End Sub

LoadPicture 函数 返回图片对象e = LoadPicture("E:图片")

e = Nothing '清空图片

Private Sub UserForm_Initialize() '初始化装入工作表名

Set d = CreateObject("nary")

For i = 1 To

d(Sheets(i).Name) = 1

Next

=

End Sub

AppActivate n '焦点移到工作表

us ‘用户窗体控件的激活

te ‘工作表控件的激活

ys "{HOME}" 窗体滚动条停于上边缘

For s = 1 To 16

Controls("TextBox" & s).Value = "" ‘控件循环清空

Next

IsDate(m)= True 判断日期

'点×无效

Private Sub CommandButton1_Click()

Unload Me

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)

If CloseMode = 0 Then Cancel = True

End Sub

'点×无效

Unload UserForm1 ' 窗体退出

e = True '在窗体退出后，显示excel主窗口

条形码控件BarCodeCtrl1

Private Sub CommandButton1_Click() ‘进度条

For t = 1 To 60000

= t / 100

DoEvents '此句作用：1、点按钮2可终止循环2、n可实时显示

n = "程序运行了" & t / 600 * 100 & "%"

Next

End Sub

LEFT(1.369,InStr(1.369,".")+2) ’截取指定位数的数字

s = Format(Date, "[DBNum1][$-804]yyyy""年""m""月""d""日"" aaaa;@")

MsgBox "今天是" & s

年Year(Date) 月 Month(Date) 日Day(Date) 日期DateSerial(2010, 4,1)

第n月天数Day(DateSerial(2010, n+1,0))

Format(Date, "aaaa") '星期几

Format(Date, "yyyy") '年

Format(Date, "m") '月

Format(Date, "d") '日

Now + TimeValue("00:00:05") ' 延时执行

Sub 缓缓输入句子()

m = Array("好", "好", "学", "习", "天", "天", "向", "上")

For i = 0 To 7

Now + TimeValue("00:00:02") ' 延时执行

[D5] = [D5] & m(i)

Next

End Sub

CreateObject("e").Speak h & "秒" '语音读出

判断英文字母： Mid("S好tr", 3, 1) Like "[a-zA-Z]" '