VBA实用代码

VBA实用代码

 

1.判断一个表的最后一行:

  i = Range("A65536").End(xlUp).Row

2.取最后一列列号：

  m = Range("dz1").End(xlToLeft).Column

3.遍历工作簿中所有表

  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

4.求某月天数

 

  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

5.禁止别人运行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()即可

6.在编程时，时常需要知道工作表是否存在，文件是否存在等，这时候，以下这些自定义函数就能派上用场了：

 

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

7.关于远程写入数据：

需要了解如下对象：

  Application：Excel应用程序。

  Workbook：Excel工作簿。

  WorkSheet：Excel工作表。

如何创建一个Excel应用程序

  创建Excel应哟功能程序使用的是CreateObject（）函数

看下面的例子：

打开Word，进入VBAIDE，添加模块后写入如下代码：

Public Sub test()

    Dim app As Excel.Application

    Dim book As Workbook

    Dim sheet As Worksheet

   

    Set app = CreateObject("Excel.Application")

   

    Set book = app.Workbooks.Add

    MsgBox book.Name

   

    For Each sheet In book.Worksheets

        MsgBox sheet.Name

    Next sheet

   

    Set sheet = book.Worksheets(1)

    sheet.Cells(1, 1) = "Hello"

    book.SaveAs "C:\Hello.xls"

    book.Close

   

    Set sheet = Nothing

    Set book = Nothing

    Set app = Nothing

   

End Sub

8.个可以让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