VBA实用代码拾零

工作中，我们经常需要实用VBA来完成我们的任务，但有时候我们并不能完全把握VBA的精髓，走了些弯路。比如，我以前判断一个表的最后一行使用的是这个办法：

i=3
do while not(isempty(sheets("工作表名").cells(i,1).value))
    i=i+1
loop

结果行数就是：i-1

后来，才发现居然用一行代码就可以实现：
i = Range("A65536").End(xlUp).Row

于是，为了使我们少走弯路，提高效益，请我们都把在各自具体工作中实现某些功能的代码贡献于此。

不一定非要完整的VBA代码，主要的是为完成某项功能的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)=m.name              '取工作表名
      cells(i,2)=sheets(m.name).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中有“字数统计”的工具，但和WPS比起来，WORD只能对整篇文档的各类字符数进行统计，而没有对已选择的文字块内的字数统计，下面的代码可以完成这一任务：

MsgBox "块内字符：    " + Str(Len(Selection))

 

利用工作表中的公式帮助简化VBA程序

利用工作表中的公式来实现复杂的数学计算可以简化程序.
尤其是一些回归方法,用程序实现的时候往往需要几重循环嵌套,要用数组,程序要写得比较复杂的.
我们可以,在工作表中的固定地方作为数据输入区域,用公式实现计算,结果显示在另一个固定区域.
每次计算的时候只要用程序实现把数据复制到输入区域中的对应单元格,然后马上能到结果区域中拿结果了.所有计算的步骤都不用程序实现,用Excel公式帮你搞定了.

对头，关于公式的运用可以再开一帖专门讨论，其实哥哥已经弄了一个，可惜没有跟上帖，原来是置顶的，怎么沉了？其实该继续置顶，我设想的常置顶包括这些内容：
1、Word、Excel、Access、PowerPoint等常用Office组件的独门技巧接龙
2、VBA实用代码（不仅仅是Excel，涵盖包括Word、Access等所有的Office组件的VBA应用
3、Excel公式（函数）运用旨要（就是哥哥原来那个函数集合，望继续置顶）

 

自动转换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 '起始行

studentno = 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

 

禁止别人运行Word程序的VBA代码禁止别人运行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()即可

 

转自Access中国论坛清风网友的几个关于文件和工作表的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 ActiveWorkbook.Names
          If UCase(n.Name) = 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 7200
       temp = 175 + (i - 3200) * 0.15
      Case 7200 To 21200
       temp = 625 + (i - 7200) * 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

2006版
Function gs(i)
Dim n As Integer
n = 1600     '起点征税额
Select Case i
      Case 0 To n
      temp = 0
      Case n To n + 500
       temp = (i - n) * 0.05
      Case n + 500 To n + 2000
       temp = 25 + (i - n - 500) * 0.1
      Case n + 2000 To n + 5000
       temp = 175 + (i - n - 2000) * 0.15
      Case n + 5000 To n + 20000
       temp = 625 + (i - n - 5000) * 0.2
      Case n + 20000 To n + 40000
       temp = 3625 + (i - n - 20000) * 0.25
      Case n + 40000 To n + 60000
       temp = 8625 + (i - n - 40000) * 0.3
      Case n + 60000 To n + 80000
       temp = 14625 + (i - n - 60000) * 0.35
      Case n + 80000 To n + 100000
       temp = 21625 + (i - n - 80000) * 0.4
      Case n + 100000 To 99999999
       temp = 29625 + (i - n - 100000) * 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