VBA 总结一 获取指定单元格信息并打印 Sub test() With Worksheets("Sheet1") Dim productname As String productname =.Cells(3, 2) productname = #8/13/2008# 日期书写方法 Debug.Print productname 二 全局变量模块一 Public strappname As String Sub test() With Worksheets("Sheet1") Dim productname As String productname = #8/13/2008# strappname = "111111" Debug.Print strappname MsgBox strappname 模块二 Sub box() Dim str1 As String str1 = "2" Debug.Print strappname & str1 三 显示 InputBox 对话框模块三 Sub inputbox 函数 () Dim sprompt As String Dim stitle As String Dim sdefault As String sprompt = " 请输入用户姓名 " stitle = " 请输入姓名 " sdefault = "111" sreturn = InputBox(sPrompt, stitle, sdefault) Debug.Print sreturn 四 MsgBox 对话框
Sub 使用 msgbox 函数退出系统 () Dim inreturn As Integer inreturn = MsgBox(" 真的退出系统吗?", vbyesno + vbquestion, " 提示 ") If inreturn = vbyes Then Application.Quit 五 IF Else Sub 填写性别 () Worksheets("sheet1").Activate With Worksheets("sheet1") If.Cells(3, 5) = " 女士 " Then.Cells(3, 7) = " 女 " Else.Cells(3, 7) = " 男 " Sub 多分支 () Dim str1 As String ' 保存输入值 Dim sprompt As String ' 提示信息 Dim stitle As String ' 标题 Dim sdefault As String ' 默认值 Dim stemp As String sprompt = " 请输入员工的职称 :" & vbnewline & _ "1: 高级工程师 " & vbnewline & _ "2: 工程师 " & vbnewline & _ "3: 助理工程师 " & vbnewline & _ "4: 技术员 " & vbnewline & _ " 输入其他值, 则无职称 " stitle = " 输入职称 " sdefault = "2" str1 = InputBox(sPrompt, stitle, sdefault) If str1 = "" Then If str1 = "1" Then stemp = " 高级工程师 " ElseIf str1 = "2" Then stemp = " 工程师 " ElseIf str1 = "3" Then stemp = " 助理工程师 " ElseIf str1 = "4" Then
stemp = " 技术员 " Else stemp = " 其他 " Worksheets("Sheet1").Range("A1") = stemp 六 For 循环 Sub 填写性别 () Worksheets("sheet1").Activate With Worksheets("sheet1") For i = 3 To 11 If.Cells(i, 5) = " 女士 " Then.Cells(i, 7) = " 女 " Else.Cells(i, 7) = " 男 " 七 传参 Sub 传值测试 (ByVal a As Integer) a = a + 1 Debug.Print " 子过程的变量 A=" & a Sub 调用传值测试 () Dim b As Integer b = 3 Debug.Print " 主程序中的变量 b=" & b 传值测试 b Debug.Print " 主程序中的变量 b=" & b 八 检查字符串长度 Sub 自定义类型的字节 () Dim asas As String mylen = Len("qqqqqqqqqqqqqqqqqqqqqqqqq") Debug.Print UCase("aaaaaaaaaaa") MsgBox " 所占字节 " & mylen 九 比较字符串
Sub 使用 like 比较字符串 () Debug.Print """abba"" Like ""a*a"" 的结果为 :"; "abba" Like "a*a" Sub 使用 StrComp 比较字符串 () Dim str1, str2, MyComp str1 = "ABCD" str2 = "abcd" Debug.Print StrComp(str1, str2, 1) Debug.Print Left(str1, 1) Sub 搜索字符串的位置 () Dim str1 As String str1 = "hello excel 2013 VBA" Debug.Print InStr(str1, "z") 十 获取日期和时间 Sub 显示系统当前日期和时间 () Dim MyDate As Date MyDate = Date MsgBox " 当前日期和时间为 :" & Now Debug.Print " 十天后的日期 " & MyDate + 10 Debug.Print " 十天后的日期 " & DateAdd("d", 10, MyDate) Sub 时间差 () Dim odate As Date, today As Date Dim t1 As Integer, t2 As Integer odate = #6/12/2014# today = #10/15/2013# t1 = DateDiff("d", today, odate) Debug.Print t1 十一 使用变量对象 Sub 对象变量 () Dim MyCell As Range Set MyCell = Worksheets(1).Range("C5") MyCell.Value = " 地址 " MyCell.Font.Name = " 黑体 " MyCell.Font.Bold = True
Sub 保存对象 () Dim MyRange(10) As Range Dim MyRange1(10) As Range For i = 1 To 10 Set MyRange(i) = Worksheets(1).Cells(i, 7) For i = 1 To 10 Set MyRange1(i) = Worksheets(1).Cells(i, 8) MyRange1(i) = MyRange(i).Value 一 复制工作表 Sub 复制工作表 () Dim ws1 As Worksheet Set ws1 = ActiveSheet MsgBox " 复制当前工作表到前面 " ws1.copy Before:=ws1 MsgBox " 复制当前工作表到后面 " ws1.copy After:=ws1 二 显示 / 隐藏工作表 Sub 隐藏工作表 () Dim str1 As String, ws1 As Worksheet str1 = Application.InputBox(Prompt:=" 请输入需要隐藏的工作表 :", _ Title:=" 隐藏工作表 ", Default:="Sheet9", Type:=2) On Error GoTo err1 Set ws1 = Worksheets(str1) ws1.visible = xlsheethidden err1: MsgBox " 输入的工作表不存在!" Sub 显示工作表 () Dim str1 As String, ws1 As Worksheet str1 = Application.InputBox(Prompt:=" 请输入需要隐藏的工作表 :", _ Title:=" 显示工作表 ", Default:="Sheet9", Type:=2) On Error GoTo err1
Set ws1 = Worksheets(str1) ws1.visible = True err1: MsgBox " 输入的工作表不存在!" Sub 显示所有工作表 () Dim ws As Worksheet For Each ws In Worksheets If ws.name <> "sheet9" Then ws.visible = xlsheetvisible 登陆框 ' 登录模块 Sub auto_open() Dim blogin As Boolean ' 标志变量, 记录用户是否登录成功 UserForm1.Show Private Sub CommandButton1_Click() If (Trim(TextBox1.Value) = "") Then MsgBox " 用户名不能为空 ", vbcritical + vbokonly, " 警告 " TextBox1.SetFocus If (Trim(TextBox2.Value) = "") Then MsgBox " 密码不能为空 ", vbcritical + vbokonly, " 警告 " TextBox2.SetFocus If TextBox1.Value = "admin" And TextBox2.Value = "123456" Then MsgBox " 欢迎进入本系统!", vbinformation + vbokonly, " 欢迎 " blogin = True Unload Me UserForm2.Show Else MsgBox " 输入的用户名或密码有误, 请重新输入!", vbcritical + vbokonly, " 警告 " TextBox1.SetFocus
Private Sub CommandButton2_Click() blogin = False Application.Quit Private Sub UserForm1_QueryClose(Cancel As Integer, CloseMode As Integer) If Not blogin Then Application.Quit ACCESS 数据库操作一 将 ACCESS 数据库的数据插入 EXCEL Sub 获取客户信息 () Dim cnn As New Connection, rs As New Recordset Dim strsql As String, i As Long, sh As Worksheet ' On Error Resume cnn.open "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=" & ThisWorkbook.Path & "\test.mdb;" ' strsql = "Select * from [user]" Set rs = cnn.execute(strsql) rs.open strsql, cnn, 1, 1 Set sh = Worksheets.Add With sh For i = 0 To rs.fields.count - 1.Cells(1, i + 1) = rs.fields(i).name.range("a2").copyfromrecordset rs.columns.autofit rs.close cnn.close Set rs = Nothing Set cnn = Nothing 二 将 EXCEL 指定行的数据插入 ACCESS 数据库 Sub 添加供应商信息 ()
Dim cnn As New Connection Dim strsql As String, i As Long, c As Long cnn.open "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=" & ThisWorkbook.Path & "\test.mdb;" strsql = "insert into [user](" With Worksheets("sheet12") c =.Range("A1").End(xlDown).Row For i = 2 To c strsql = strsql &.Cells(1, i) & "," strsql = Left(strSql, Len(strSql) - 1) & ") values(" For i = 2 To c strsql = strsql & "'" &.Cells(i, 2) & "'," strsql = Left(strSql, Len(strSql) - 1) & ")" Debug.Print strsql cnn.execute strsql cnn.close Set cnn = Nothing 三 用 EXCEL 更新 ACCESS 表中的数据 Sub 修改联系人姓名 () Dim cnn As New Connection, strcon As String Dim strsql As String, custid As String, custname As String With Worksheets("sheet12") custid =.Range("B2") custname =.Range("C2") If Trim(custID) = "" Or Trim(custName) = "" Then MsgBox " 请输入 公司名称 和 联系人姓名 信息!", vbcritical + vbokonly 'On Error Resume cnn.open "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=" & ThisWorkbook.Path & "\test.mdb;"
strsql = "UPDATE [user] SET 联系人姓名 ='" & custname & _ "'WHERE 公司名称 ='" & custid & "'" Debug.Print strsql cnn.execute strsql cnn.close Set cnn = Nothing 四 用 EXCEL 删除表中数据 Sub 删除记录 () Dim cnn As New Connection Dim strcon As String, strsql As String, custid As String custid = Worksheets("sheet12").Range("B2") If Trim(custID) = "" Then MsgBox " 请输入 客户 ID 信息!", vbcritical + vbokonly 'On Error Resume cnn.open "Provider=Microsoft.Jet.OLEDB.4.0;" _ & "Data Source=" & ThisWorkbook.Path & "\test.mdb;" strsql = "DELETE FROM [user] WHERE 公司名称 ='" & custid & "'" Debug.Print strsql cnn.execute strsql cnn.close Set cnn = Nothing 连接 ORACLE 参考 Dim strsql As String strsql = "DRIVER={Microsoft ODBC for Oracle};UID=" strsql = strsql & [user].value & ";PWD=" strsql = strsql & [Password].Value & ";SERVER=(DESCRIPTION=(ADDRESS=(PROTOCOL=tcp)(HOST=" strsql = strsql & [ip].value strsql = strsql & ")(PORT=" strsql = strsql & [port].value
strsql = strsql & "))(CONNECT_DATA=(SID=" strsql = strsql & [sid].value strsql = strsql & ")));"