Sub 使用 msgbox 函数退出系统 () Dim inreturn As Integer inreturn = MsgBox(" 真的退出系统吗?", vbyesno + vbquestion, " 提示 ") If inreturn = vbyes Then Application.Quit

Size: px

Start display at page:

Download "Sub 使用 msgbox 函数退出系统 () Dim inreturn As Integer inreturn = MsgBox(" 真的退出系统吗?", vbyesno + vbquestion, " 提示 ") If inreturn = vbyes Then Application.Quit"

鲁储
7 years ago
Views:

1 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 对话框

2 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

3 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 九比较字符串

4 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

5 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

6 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

7 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 添加供应商信息 ()

8 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;"

9 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

10 strsql = strsql & "))(CONNECT_DATA=(SID=" strsql = strsql & [sid].value strsql = strsql & ")));"

投稿類別：電子工程類

投稿類別：電子工程類投稿類別 : 工程技術類篇名 : 井字生死戰攻略作者 : 陳威宇國立臺南高級海事水產職業學校電子科二年甲班邱富群國立臺南高級海事水產職業學校電子科二年甲班指導老師 : 林育助老師王彥盛老師壹前言家喻戶曉的井字遊戲 (Tic-Tac-Toe)