vba实用代码
vba实用代码 2006-09-12 21:40:59| 分类： 杂文 | 标签： |字号大
中
小 订阅
VBA实用代码
取最后一行行号：i = Range("A65536").End(xlUp).Row
取最后一列列号：m = Range("dz1").End(xlToLeft).Column
（这是从行号类推出来的，dz列有130列，在日常使用中应该差不多了）
下面的代码将在当前工作表中显示整个工作簿中所有表的表名和第一个第一个的内容
i=1
For Each m In Sheets '遍历每个工作表
cells(i,1)=https://www.360docs.net/doc/da9448494.html, '取工作表名
cells(i,2)=sheets(https://www.360docs.net/doc/da9448494.html,).cells(1,1) '取工作表第一个第一个内容
i=i+1
next
--------------------------------------------------------------------------------
求某月天数
Function tianshu(riqi As Date) As Byte
tianshu = DateSerial(Year(riqi), Month(riqi) + 1, Day(riqi)) - riqi
End Function
'求月末日期
Function yuemo(riqi As Date) As Date
yuemo = DateSerial(Year(riqi), Month(riqi) + 1, 0)
End Function
禁止别人运行Word程序的VBA代码
单击“工具→宏→宏…”命令，在弹出的对话模型中输入宏名“autoexec”，然后单击“创建”，在代码窗中输入如下内容，即可控制别人运行WORD：
Sub autoexec()
Dim psw As String
psw = inputbox("请输入密码：", "登录？")
If psw = "elong" Then
Application.ShowMe
Else
msgbox "对不起，请您与本机主人联系!"
Application.Quit
End If
End Sub
破解办法：
1、禁止自运行宏、
2、或者直接删除normal.dot模板文件即可。
补充：
这个代码也可以用在Excel中，只是函数名换成Auto_Open()即可关于文件和工作表的VBA函数帖
在编程时，时常需要知道工作表是否存在，文件是否存在等，这时候，以下这些自定义函数就能派上用场了：
Private Function FileExists(fname) As Boolean
'当文件存在时返回true
Dim x As String
x = Dir(fname)
If x <> "" Then FileExists = True _
Else FileExists = False
End Function
Private Function FileNameOnly(pname) As String
'返回路径pname的文件名
Dim i As Integer, length As Integer, temp As String
length = Len(pname)
temp = ""
For i = length To 1 Step -1
If Mid(pname, i, 1) = Application.PathSeparator Then
FileNameOnly = temp
Exit Function
End If
temp = Mid(pname, i, 1) & temp
Next i
FileNameOnly = pname
End Function
Private Function PathExists(pname) As Boolean
'如果路径pname存在则返回true
Dim x As String
On Error Resume Next
x = GetAttr(pname) And 0
If Err = 0 Then PathExists = True _
Else PathExists = False
End Function
Private Function RangeNameExists(nname) As Boolean
'如果一个名称存在则返回true
Dim n As Name
RangeNameExists = False
For Each n In https://www.360docs.net/doc/da9448494.html,s
If UCase(https://www.360docs.net/doc/da9448494.html,) = UCase(nname) Then
RangeNameExists = True
Exit Function
End If
Next n
End Function
Private Function SheetExists(sname) As Boolean
'如果活动工作簿中存在表SNAME则返回真
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then SheetExists = True _
Else SheetExists = False
End Function
Private Function WorkbookIsOpen(wbname) As Boolean
'如果工作簿WBNAME打开着，则返回true
Dim x As Workbook
On Error Resume Next
Set x = Workbooks(wbname)
If Err = 0 Then WorkbookIsOpen = True _
Else WorkbookIsOpen = False
End Function
征收个税计算公式
Function gs(i)
Select Case i
Case 0 To 1200
temp = i * 0
Case 1200 To 1700
temp = (i - 1200) * 0.05
Case 1700 To 3200
temp = 25 + (i - 1700) * 0.1
Case 3200 To 6200
temp = 175 + (i - 3200) * 0.15
Case 6200 To 21200
temp = 625 + (i - 6200) * 0.2
Case 21200 To 41200
temp = 3625 + (i - 21200) * 0.25
Case 41200 To 61200
temp = 8625 + (i - 41200) * 0.3
Case 61200 To 81200
temp = 14625 + (i - 61200) * 0.35
Case 81200 To 10200
temp = 21625 + (i - 81200) * 0.4
Case 10200 To 99999999
temp = 29625 + (i - 101200) * 0.45
Case Else
MsgBox "输入无效！请重新输入！"
End Select
gs = Round(temp, 2)
End Function
一段可以双击列表题自动按双击列排序的代码，
添加到工作表双击事件即可
Dim rg As Range
If Target.Column <= Me.Cells _(1,1).CurrentRegion.Columns.Count _
And Target.Row = 1 Then
If Target.Column <> mnColumn Then
mnColumn = Target.Column
mnDirection = xlAscending
Else
If mnDirection = xlAscending Then
mnDirection = xlDescending
Else
mnDirection = xlAscending
End If
End If
Set rg = Me.Cells(1, 1).CurrentRegion
rg.Sort key1:=rg.Cells(1, mnColumn), order1:=mnDirection, _ header:=xlYes
Set rg = Nothing
Cancel = True
End If
看到很多关于分页小计（每页页底增加一行本页相关数据的汇总数据，在财务方面使用很广）的需求，可以用下面的代码完成：
比如A列是“产品”，B列是“金额”。现对“金额”进行分页小计
Dim i, t, l, x, rr, dr, tt As Integer
Dim rrr As String
Public Sub Fyhz()
t = 2
Do
i = InputBox("请输入每页拟打印的行数： （不能超过一页的范围！！！）")
If i <= 0 Or i = "" Then
MsgBox ("每页行数必须大于1！")
Else
Exit Do
End If
Loop
i = Int(i)
x = i + 1
l = Range("A65536").End(xlUp).Row
Do While l >= x
Rows(x + 1).Insert Shift:=xlDown
Cells(x + 1, 1) = "本页小计"
Cells(x + 1, 2).Formula = "=SUM(R[-" + CStr(i) + "]C:R[-1]C)"
ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=Rows(x + 2)
x = (i + 1) * t
t = t + 1
l = l + 1
Loop
If l Mod (i + 1) <> 1 Then
rr = l Mod (i + 1
)
rr = rr - 1
rrr = CStr(rr)
Cells(l + 1, 1) = "本页小计"
Cells(l + 1, 2).FormulaR1C1 = "=SUM(R[-" + rrr + "]C:R[-1]C)"
End If
Cells(l + 2, 1) = "合计"
Cells(l + 2, 2).FormulaR1C1 = "=SUM(R[-" + CStr(l + 1) + "]C:R[-1]C)/2"
Range(Cells(1, 1), Cells(l + 1, 2)).Locked = True
ActiveSheet.Protect
Cells(1, 1).Select
在页眉页脚中调用单元格内容:
Worksheets("Sheet1").PageSetup.CenterHeader = Sheet1.range("B1")
--------------------------------------------------------------------------------
一个可以让Excel、Access等程序播放声音文件的函数（只能放WAV文件）
会让你的系统或者表格别具一格哦 :)
使用方法：=PlaySound("声音文件名.WAV") (声音文件必须含路径和扩展名)
=PlaySound(A1) (A1单元格中存放声音文件名)
Declare Function apisndPlaySound Lib "winmm" Alias "sndPlaySoundA" _
(ByVal filename As String, ByVal snd_async As Long) As Long
Function PlaySound(sWavFile As String)
If apisndPlaySound(sWavFile, 1) = 0 Then
MsgBox "The Sound Did Not Play!"
End If
End Function
--------------------------------------------------------------------------------
使用Sheel()函数在Excel中调用Word并打开一个DOC文档
这可是我们经常要用到的哦
Sub OpenDOC()
Dim RetVal
Dim filen As String
filen = InputBox("请输入文件名（含路径和扩展名）")
RetVal = Shell("D:\Programs\Microsoft Office\OFFICE11\WINWORD.EXE " + filen, vbNormalFocus)
Cells(1, 1) = RetVal
End Sub
--------------------------------------------------------------------------------
使用Replace()函数统计一个字符串在另一个字符串中出现的次数自定义函数：
Public Function strCount(strA As String, strB As String) As Long
Dim lngA As Long
Dim lngB As Long
Dim lngC As Long
lngA = Len(strA)
lngB = Len(strB)
lngC = Len(Replace(strA, strB, ""))
strCount = (lngA - lngC) / lngB
End Function
--------------------------------------------------------------------------------
在 Excel 表中检查重复字段值的方法
在大的数据文件入库前，往往要对数据文件做一些预处理工作，如人员信息在数据采集阶段可按部门统计到EXCEL表中，最后集中导入大型数据库（如ORACLE等），在这个过程中，因数据的唯一性问题导致的错误往往使你累得头昏脑涨：如人员信息中，稍不注意就会将身份证号重复输入，因为在此表中身份证号一般用作主键，有重复数据就不能入库，这种错误相当隐蔽，不容易检查。为此笔者编制了一段程序，可以自动检测包含相同字段值的记录，即用Excel的宏调用实现此功能，具体方法如下：
打开Excel文件，选择“工具”，宏，录制新宏，确定；然后点击宏，出现宏名为“宏1”，点击编辑，将VB SCRIPT 输入：
Sub 宏
1()
' 定义两个变量
Dim a, b
'EXCEL文件名字为：renyuanxx.xls
Sheets("renyuanxx").Select
'假设记录数为10000
For i = 1 To 10000
' 假设要检查的列为第8列
a = Cells(i + 1, 8)
For j = i + 1 To 10000
b = Cells(j + 1, 8)
If b = a Then
'如果有相同的值就打印输出
MsgBox b
End If
Next j
Next i
End Sub
然后按状态栏里的执行键，就开始检查了，相同的字段名会提示在屏幕上。
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
--------------------------------------------------------------------------------
获取块内字数
WORD中有“字数统计”的工具，但和WPS比起来，WORD只能对整篇文档的各类字符数进行统计，而没有对已选择的文字块内的字数统计，下面的代码可以完成这一任务：
MsgBox "块内字符： " + Str(Len(Selection))
--------------------------------------------------------------------------------
自动转换15位身份证号码位18位
功能：将15的身份证号升为18位(根据GB 11643-1999)
参数：原来的号码（15位）
返回：升位后的18位号码
用法：=IDCODE(a1) （假设A1单元格存放的是原15位号码）
Public Function IDCode(sCode15 As String) As String
Dim i,num As Integer
Dim code As String
num = 0
IDCode = Left(sCode15, 6) + "19" + Right(sCode15, 9)
' 计算校验位
For i = 18 To 2 Step -1
num = num + (2 ^ (i - 1) Mod 11) * (Mid(IDCode, 19 - i, 1))
Next i
num = num Mod 11
Select Case num
Case 0
code = "1"
Case 1
code = "0"
Case 2
code = "X"
Case Else
code = Trim(Str(12 - num))
End Select
IDCode = IDCode + code
End Function
--------------------------------------------------------------------------------
用excel实现自动批卷，并得出不同题号间的正确数（这部分代码是我自己加的）！和大家分享！
Sub test()
Dim studentno '学号
Dim rwIndex As Integer '行号
Dim clIndex As Integer '列号
Dim tAnswer As String '标准答案
Dim sAnswer As String '学生答案
Dim trueNumber As Integer '正确数
Dim wrongNumber As Integer '错误数
Dim total1 As Double '客观前10题正确数
Dim total2 As Double '客观前20题正确数
Dim total3 As Double '客观前40题正确数
Dim total4 As Double '客观前70题正确数
rwIndex = 2 '起始行
st
udentno = Sheet1.Cells(rwIndex, 3)
Do While (studentno <> "")
clIndex = 4 '起始列
trueNumber = 0
wrongNumber = 0
total = 0
Worksheets("Sheet1").Rows(rwIndex + 1).Insert '插入一行
sAnswer = Sheet1.Cells(rwIndex, clIndex)
tAnswer = Sheet2.Cells(2, clIndex)
'判断一个学生的选择题
Do While (sAnswer <> "") '到底怎样控制结束
If Trim(sAnswer) = Trim(tAnswer) Then '比对客观的答案
Sheet1.Cells(rwIndex + 1, clIndex) = "对"
trueNumber = trueNumber + 1 '正确数加一
Else
Sheet1.Cells(rwIndex + 1, clIndex) = "错"
wrongNumber = wrongNumber + 1
End If
If clIndex = 13 Then total1 = trueNumber
If clIndex = 23 Then total2 = trueNumber
If clIndex = 43 Then total3 = trueNumber
If clIndex = 73 Then total4 = trueNumber
clIndex = clIndex + 1
tAnswer = Sheet2.Cells(2, clIndex)
sAnswer = Sheet1.Cells(rwIndex, clIndex)
Loop
Sheet1.Cells(rwIndex + 1, clIndex) = trueNumber
Sheet1.Cells(rwIndex + 1, clIndex + 1) = total1 * 1 + (total2 - total1) * 1 + (total3 - total2) * 2 + (total4 - total3) * 0.5 + (trueNumber - total4) * 0.5
Sheet1.Cells(rwIndex + 1, clIndex + 2) = total1 '1-10题的正确数
Sheet1.Cells(rwIndex + 1, clIndex + 3) = total2 - total1 '10-20题的正确数
Sheet1.Cells(rwIndex + 1, clIndex + 4) = total3 - total2 '20-40题的正确数
Sheet1.Cells(rwIndex + 1, clIndex + 5) = total4 - total3 '40-70题的正确数
Sheet1.Cells(rwIndex + 1, clIndex + 6) = trueNumber - total4 '70-90题的正确数
rwIndex = rwIndex + 2
studentno = Sheet1.Cells(rwIndex, 3)
Loop
Sheet1.Cells(1, clIndex) = "正确数"
Sheet1.Cells(1, clIndex + 1) = "得分"
Sheet1.Cells(1, clIndex + 2) = "1-10“对话听力”正确数"
Sheet1.Cells(1, clIndex + 3) = "10-20“短文听力”正确数"
Sheet1.Cells(1, clIndex + 4) = "20-40“阅读理解”正确数"
Sheet1.Cells(1, clIndex + 5) = "40-70“词汇与结构”正确数"
Sheet1.Cells(1, clIndex + 6) = "70-90“完型填空”正确数"
End Sub