vba编程题库.doc

1、编一个VBA程序，将Word当前文档中光标右边的大写字母转换为小写字母。 Selection.MoveRight Unit:=wdCharacter, Count:=1, Extend:=wdExtend n= Asc(Selection.Text) If n = 65 And n = 90 Then Selection.TypeText Text:=Chr(n + 32) Else Selection.MoveRight Unit:=wdCharacter, Count:=1 End If 2、 编一个VBA程序，在Word当前文档中按顺序输入26个英文字母。For i = Asc(a) To Asc(z)Selection.TypeTextText:=Chr(i) Next3、新建一个窗体，放置两个按钮和一个文字框控件。按钮的标题分别定义为“显示”和“清除”。单击“显示”按钮，在文字框中显示一行文字，单击“清除”按钮，清除文字框中的文字。进入VBA编辑环境，打开“工程资源管理器”窗口，插入一个用户窗体。在窗体上放置两个命令按钮和一个文字框。右击命令按钮,选“属性”，设置Caption属性值为“显示”、“清除”。双击“显示”命令按钮，输入如下代码： Me.TextBox1.SetFocus Me.TextBox1.Text = 你好！欢迎学习VBA双击“清除”命令按钮，编写代码如下： Me.TextBox1.Text = 双击用户窗体，为其Activate事件编写如下代码： Me.Caption = 欢迎！4、假设某文件夹有20个属性相同、命名有规律（比如：pic01.gif、pic02.gif、pic20.gif）的图片文件，现在要依次放入PowerPoint幻灯片中，并调整为合适的格式。，录制宏 输入标题、插入图形、调整格式。加工录制的程序。设置路径、循环、使用变量。运行程序。5、编写一个自定义函数，根据“工资及津贴”数额求出应缴纳党费的比例。Function df(x)Select Case xCase Is = 400 y = 0.005Case Is = 800 y = 0.01Case Is = 1200 y = 0.015Case Is = 1500 y = 0.02Case Else y = 0.03End Selectdf = yEnd Function6、用递归方法编写一个函数，求n的阶乘。 Function fact(n) If n = 1 Then fact = 1 Else fact = n * fact(n - 1) End If End Function7、要想在Excel工作簿的任意一个单元格中输入数字“1”后，自动替换为符号“”， 建立Excel工作簿，进入VB编辑环境，对ThisWorkbook的SheetChange事件编写如下程序：Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) If Target.Value = 1 Then Target.Value = End Sub8、在Word中，要想用快捷键执行宏的方式快速将某一字符变为上角标录制新宏，设置快捷键，进行宏录制。选中字符，在“字体”窗口的“效果”栏中选中“上标”，停止录制宏。 光标定在字符左边，按快捷键，即可转换为上角标。9、假设Excel当前工作表的A列是应参加会议人员名单，要求当每个与会人员报道时，在其姓名右边的单元格（B列）单击鼠标，自动填入当前日期和时间。建立Excel工作簿，进入VBA编辑环境，对WorkSheet的SelectionChange事件编写如：PrivateSubWorksheet_SelectionChange(ByVal Target As Range) col_s = Target.Column If col_s = B ThenTarget.Value=Format(Now,yyyy-mm-dd hh:mm:ss) End IfEnd Sub10、假设在Excel工作表中已经建立一个“XX高校教师信息表”。 进入VBA编辑环境，在当前工程中插入一个模块，建立如下自定义函数：Function age(id As String)id = Trim(id) If Len(id) = 18 Then age = Year(Date) - Val(Mid(id, 7, 4) Elseage = Year(Date) - Val(19 + Mid(id, 7, 2) End If在“年龄”列第一个单元格输入计算公式“=age(X)”，其中X是对应的身份证号单元格地址，并将公式填充到该列的其他单元格。11、编写程序，将Excel任意选定的两个单元格的内容互换Sub ChangV()v = ActiveCell.Value For Each a In Selection Ifa.AddressActiveCell.Address Then ActiveCell.Value = a.Value a.Value = v End If NextEnd Sub12、编写程序，在打开Excel时提示密码输入，如果错误则使用Application.Quit退出Excel。Sub auto_Open() If Application.InputBox(请输入密码: ) = 123 Then Exit Sub Else Application.Quit End If End Sub13、编写一段程序，求某门课程的平均分。要求用InputBox函数输入学生的人数和每个人的分数，用MsgBox语句输出平均分。Sub pjf() rs = InputBox(输入学生的人数：) zf = 0 For k = 1 To rsf = InputBox(输入考试成绩 & k)zf=zf+f Next MsgBox (rs & 位学生的平均分是： & zf / rs)End Sub14、设计一个判断三角形是否为直角三角形的子程序，它带有三个整型参数a、b和c分别表示三角形的三条边。Sub cag(a As Integer, b As Integer, c As Integer) If a 2 + b 2 = c 2 Or a 2 + c 2 = b 2 Or b 2 + c 2 = a 2 Then MsgBox 是直角三角形 Else Msgbox 不是直角三角形 End IfEnd Sub15、要想在Excel工作簿打开时建立一个名为“功能”的工具栏，在工具栏上添加一个按钮（按钮的capition任意，要执行的过程名任意），并且让工具栏可见。请写出工作簿Open事件的子程序。Private Sub Workbook_Open() Settbar= Application.CommandBars.Add(Name:=功能)Setbutt=tbar.Controls.Add(Type:=msoControlButton) With butt .Caption = 取字模 .Style= msoButtonCaption .OnAction = qzm End With tbar.Visible = TrueEnd Sub16、编写一个子程序，使用工作表函数求出“Sheet1”工作表A1:D10区域中的最小值。Sub aa() Dim myR As RangeSetmyR=Worksheets(Sheet1).Range(A1:D10)b=Application.WorksheetFunction.Min(myR) MsgBox bEnd Sub17、编写一个子程序，将Excel当前工作表“A1:H8”区域的每行填涂一种不同颜色。Sub kk() For i = 1 To 8 For j = Asc(A) To Asc(H) c = Chr(j) & iRange(c).Interior.ColorIndex = i Next j Next iEnd Sub18、假设Excel当前工作表是某个班级学生成绩单（50人），第一列是姓名，第二、三、四列是三科成绩，试编一段VBA程序，通过输入框输入姓名后，查询并显示该学生的三科成绩和总成绩。xm = InputBox(请输入姓名：)For I = 1 To 50 If Range(A & I) = xm Then cj1 = Range(B & I) cj2 = Range(C & I) cj3 = Range(D & I) zcj = cj1 + cj2 + cj3 MsgBox 该生成绩分别为： & cj1 & cj2 & cj3 & 总成绩为： & zcj End IfNext19、编写一段程序，在Excel工作簿中添加一个叫“选择模板”的工具栏，在工具栏上添加两个按纽叫“开始”和“退出”并分别调用KS、TC两个子程序。Settbar=Application.CommandBars.Add(Name:=选择模板)Set butt1 = tbar.Controls.AddWith butt1 .Caption = 开始 .OnAction = ksEnd WithSet butt2 = tbar.Controls.AddWith butt2 .Caption = 退出 .OnAction = tcEnd Withtbar.Visible = True20、编写一个求斐波那契数列第n项值的递归函数。该数列为：1 1 2 3 5 8 13 21。Function fib(n) If n = 1 Or n=2 Then fib = 1 Else fib = fib(n - 1) + fib(n - 2) End IfEnd Function21、编写一个子程序，在Excel当前工作表的F5到J28填入1到5之间的随机整数。Sub mnsj() For i = 5 To 28For j = 6 To 10Cells(i,j) = Int(Rnd * 5) + 1 NextNextEnd Sub22、编写一个子程序，当工作簿中工作表被切换时，对工具栏中按钮的可用性进行控制。要求当前工作表为“总分”或“信息”时，使工具栏按钮“butt1”不可用，否则可用。PrivateSubWorkbook_SheetActivate(ByVal Sh As Object) If Sh.Name = 总分 Or Sh.Name = 信息 Then Butt1.Enabled = False Else Butt1.Enabled = True End IfEnd Sub23、在工作簿打开时，首先显示封面窗体UserForm1，然后建立一个工具栏命名为“竞赛评分”，在工具栏上添加一个命令按钮“汇总”，为按钮指定17号图符，并指定要执行的过程为“hz”。Private Sub Workbook_Open() UserForm1.ShowSettbar=Application.CommandBars.Add(Name:=竞赛评分)Setbutt=tbar.Controls.Add(Type:=msoControlButton) With butt .Caption = 汇总 .FaceId = 17 .Style=msoButtonIconAndCaption .OnAction = hz End WithEnd Sub24、编写一个子程序，将当前Word文档选中的文本所有单词“ABC”替换为“VBA”。Sub cz() With Selection.Find .Text = ABC .Replacement.Text = VBA.Execute Replace:=wdReplaceAll End WithEnd Sub25、编写一个子程序，求Range(“A2:A20”)区域中数据的平均值，填入Cells（2，3）中。要求四舍五入，保留小数点后两位。Sub 平均值() zf = 0 For i = 2 To 20 zf = zf + Cells(i, 1) Next i Cells(2, 3).Value = Int(zf / 19 * 100 + 0.5) / 100End Sub26、编写一个子程序，求Range(“A2:A20”)区域中数据的最大值和最小值（假设数据的范围在0到100之间），并用消息框的形式显示出来。Sub dxz()Set myr = Range(a2:a20)a=Application.WorksheetFunction.Min(myr)b=Application.WorksheetFunction.Max(myr) MsgBox 最大值为: & b & Chr(10) & 最小值为: & aEnd Sub27、已知工作表中第1列从第1行开始到第40行有40个考试成绩数据，试编写一个子程序求出最高分并用消息框显示出来。Sub zg() zgf = Range(A1) For i = 1 To 40 If Range(A & i) zgf Then zgf = Range(A & i) End If Next MsgBox 最高分是: & zgfEnd Sub28、已知当前工作表“A1:A60”区域是某考查课成绩，试编写一个子程序求出“良好”人数并将“良好”单元格填充上颜色。Sub gs() k = 0 For h = 1 To 60 If Cells(h, 1) = 良好 Then Cells(h,1).Interior.ColorIndex = 5 k = k + 1 End IfNext MsgBox 良好的人数: & kEnd Sub29、已知当前工作表第1列有1000个无规则的数据，有的单元格为空，有的单元格里前几个字符是空格。试编写一程序删除空单元格，将单元格内容前面的空格去掉，最后计算有多少个非空单元格。k = 1000For i = 1 To 1000 Range(A & i) = Trim(Range(A & i) If Range(A & i) = Then Range(A & i).Delete k = k - 1 End IfNext30、编写一段程序，将Excel当前工作簿“Sheet1”第一行的内容按原位置粘贴到“Sheet2”中Worksheets(Sheet1).Rows(1).Copy Worksheets(Sheet2).Rows(1)31、设计一个子程序，找出100800范围内所有能同时被3和8整除的自然数，依次填写到当前工作表的第一列。Sub 方法1() i = 1 For n = 100 To 800 If (n Mod 3 = 0) And (n Mod 8 = 0) Then Cells(i, 1).Value = n i = i + 1 End If Next nEnd Sub32、编写一个子程序，任意输入两个正整数，求它们的最大公约Sub aa() m = InputBox(请输入第一个正整数) n = InputBox(请输入第二个正整数) If n m Then t = m: m = n: n = tDo p = m Mod n m = n n = p Loop While p 0 MsgBox mEnd Sub33、用VBA编写一个四舍六入函数Public Function sslr(x, n) x = x * 1000 x = Str(x) p = InStr(x, .) y = Mid(x, p + 1, 1) If y 5 Then j = 1 ElseIf y = 5 Then q = Mid(x, p - 1, 1) If q Mod 2 = 0 Then j = 0 Else j = 1 End If Else j = 0 End If x = Left(x, p - 1) x = Val(x) + j sslr = x / 1000End Function 34、单元格A1内容为字符串“月、2月、3月.10月、11月、12月”，请用vba实现把“月”删除，将单元格A1内容变为“1、2、3.10、11、12”A1=Application.WorksheetFunction.Substitute(A1, 月, )35、在工作表sheet2中使用Worksheet_Activate()事件，实现单击Sheet2时，在Sheet1的A列的最后一个记录的下一行自动填上“End”。PrivateSubWorksheet_Activate()dim i as integeri= Sheets(Sheet1).Cells(1, 1).CurrentRegion.Rows.CountSheets(Sheet1).Cells(i + 1, 1) = EndEnd Sub36、编写程序，在打开Excel表格时提示输入密码，共有三次机会，三次错误后退出应用程序。Sub auto_Open()If Application.InputBox(请输入操作权限密码:, 系统登陆) = 123 ThenElseMsgBox 密码错误,请重输, vbCritical + vbOKOnly, 你还有两次机会If Application.InputBox(请输入操作权限密码:, 系统登陆) = 123 ThenElseMsgBox 密码错误,再给你一次机会!, vbCritical + vbOKOnly, 你还有一次机会If Application.InputBox(请输入操作权限密码:) = 123 ThenElseMsgBox 你无权进入本系统! , vbCritical + vbOKOnly, 你没有机会啦!Application.QuitEnd IfEnd IfEnd IfEnd Sub37、Excel中列号用字母表示，列号9，对应的字母应该是I,列号27，对应的字母应该是AA。用vba编写一个函数，将列号转变为对应的字母。（最大列号为256）FunctionColumnLetter(ColumnNumber As Integer) As String If ColumnNumber 256 Then MsgBox 无效列号 Exit FunctionElseIf ColumnNumber 26 ThenColumnLetter=Chr(Int(ColumnNumber - 1) / 26) + 64) & _Chr(ColumnNumber - 1) Mod 26) + 65)ElseColumnLetter=Chr(ColumnNumber + 64) End IfEnd Function38、简单描述并编程实现下列过程：在打开一个主文件“main.doc”的同时，相关的其他三个文件自动打开“test.doc”、“answer.doc”及“chart.doc”。进入VBE环境，用“工程资源管理器”选择“main”工程，在该工程的“Microsoft Word”对象中双击“This Document”，对Document对象的Open事件编写如下代码：PrivateSub Document_Open() Documents.Open FileName:=test.doc Documents.Open FileName:=answer.doc Documents.Open FileName:=chart.docEnd Sub39、编程实现在文档的末尾插入该文档每次被打开的时间。在用户打开文档时发生该事件。PrivateSub Document_Open() Dim rngCurrent As RangeSetrngCurrent= ActiveDocument.ContentWith rngCurrent.collapse wdCollapseEnd.InsertDateTime”MM/dd/yy HH:MM:SS”,FalseEnd with SetrngCurrent= ActiveDocument.ContentWith rngCurrent.InsertParagraphAfter.Collapse wdCollapseEnd.SelectEnd with End Sub40、编程序，将八进制正整数组成的字符串转换为十进制整数。Sub kk() b = InputBox(请输入一个八进制数：) n = Len(b) s = 0 For i = 1 To n k = Mid(b, i, 1) s = s * 8 + k Next MsgBox sEnd Sub41、编写一个循环程序，计：s=1+12+123+1234+12345+.。项目数通过键盘指定。Sub kk() n = InputBox(n=?) s = 0: t = 0 For i = 1 To n t = t * 10 + i s = s + t Next MsgBox sEnd Sub0170 06F342、编写程序检查一个字符串是否为回文，是回文时，输出“yes!”，否则输出“no!”。所谓回文即正向与反向的拼写都一样，例如：adgda。Sub kk()s = InputBox(请输入一个字符串：)n = Len(s)p1 = 1: p2 = nDo While p1 p2If Mid(s, p1, 1) Mid(s, p2, 1) Then MsgBox No!Exit Sub End If p1 = p1 + 1 p2 = p2 - 1 Loop MsgBox Yes!End Sub42、编程将Excel当前工作表第1行的所有数据元素逆置。Sub kk() i = 1j=Rows(1).End(xlToRight).Column Do While i j t = Cells(1, i) Cells(1,i)= Cells(1, j) Cells(1, j) = ti = i + 1: j = j - 1 LoopEnd Sub43、编写一个程序，将Excel如图所示的原数据区的数据复制到目标数据Sub 方法之一() For k = 1 To 8 r = 11 + (k - 1) Mod 4) * 5 c = IIf(k 1 And i = 0 And a = 9 Then b = b & a End If Next MsgBox bEnd Sub50、编写程序，输出所有“对等数”。“对等数”是指一个三位数，其各位数字的和与各位数字的积的积等于该数本身。例如：144(1+4+4)*(1*4*4)。Sub kk() For n = 100 To 999 i = n 100 j = n 10 - i * 10 k = n Mod 10 If n = (i + j + k) * i * j * k ThenSelection.TypeText Text:=Format(n, ) End If NextEnd Sub51、编写一个双重循环结构的VBA程序，在Word当前文档输出如下形式的方阵： For j = 4 To 1 Step -1 For i = 1 To 4 x = (j - 1) * 4 + iSelection.TypeTextText:=Format(x,) NextSelection.TypeParagraph Next0182 07F252、在Word中编写一个双重循环结构的VBA程序，实现如下功能：输入一个整数给n（n10）后，输出n行由大写字母A开始构成的三角形字符阵列图形。例如，输入整数5时，程序运行结果如下：A B C D EF G H IJ K LM NO n = InputBox(n=?) c = Asc(A) For i = 1 To n For j = 1 To n - i + 1Selection.TypeText Text:=Format(Chr(c), ) c = c + 1 NextSelection.TypeParagraph Next53、100匹马驮100担货，大马一匹驮3担，中马一匹驮2担，小马两匹驮1担。请编一个VBA程序，求大、中、小马可能的数 For x = 0 To 33 For y = 0 To 50 z = 100 - x - y If 3 * x + 2 * y + 0.5 * z = 100 Then g = g & 大马 & x & ,中马 & y & ,小马 & z & Chr(10)End IfNext NextMsgBox (g)54、设Excel当前工作表第一行有n个升序排列的数值，第二行有m个升序排列的数值。编一个VBA程序，将第二行的数据合并到第一行中且保序。n=Rows(1).End(xlToRight).Column 求第一行列数m=Rows(2).End(xlToRight).Column Fori=1Tom a = Cells(2, i)For j = n To 1 Step -1 If a Max Then Max = Cells(Row, col) End If Next If Row = 1 Then Min = Max ElseIf Max 0 Then n1 = Val(tt) n2 = Val(Mid(tt, p + 1) k = n2 - n1 + 1 Else k = 0 p = InStr(tt, A)Do While p 0 k = k + 1 p = InStr(p + 1, tt, A) Loop End If MsgBox i & 行 & j & 列单元格有 & k & 个“A”。 NextNext58、在Word当前文档中，显示Fibonacci（斐波那契）数列的前30项。Sub 递推方法() f1 = 1 f2 = 1 Selection.TypeText Text:=f1 & & f2 & For N = 3 To 30 f3 = f1 + f2Selection.TypeText Text:=f3 & f1 = f2 f2 = f3 NextEnd Sub59、五只猴子分一堆桃子。第一只猴子把桃子均分成五份后，发现多一个，它吃掉这个桃子，并拿走了其中的一份。第二只猴子把剩余的桃子均分成五0189Sub 方法1() n = 6Dos=n k=0 For m = 4 To 1 Step -1 s = (s / 4) * 5 + 1 If Int(s) = s Then k = k + 1 Next n = n + 5 Loop Until k = 4 MsgBox (至少应该有 & s & 个桃子！)End Sub60、在Word中，用VBA程序在一定范围内验证哥德巴赫猜想：任何一个大于5的偶数，可以表示为两个素数之和。Sub out_e() n = 6 Doj = 2DoIf isprime(j) And isprime(n - j) ThenSelection.TypeText Text:=n & = & j & + & n - j & Chr(10)Selection.EndKeyUnit:=wdStory Exit Do End If j = j + 1 Loopn = n + 2 LoopEnd SubFunction isprime(n) For k = 2 To Sqr(n) If n Mod k = 0 Then isprime = False Exit Function End IfNextisprime = TrueEnd Function61、编写一个能随机产生算术运算符（+、-、*、/）的函数。 Public Function ysf() x = Int(Rnd() * 4) Select Case x Case 0 ysf = + Case 1 ysf = - Case 2 ysf = * Case 3 ysf = / End Select End Function61、公鸡每支5元，母鸡3元，小鸡3支1元。用100元买100只鸡，问公鸡、母鸡、小鸡各多少只？ For x = 0 To 19 For y = 0 To 33 z = 100 - x - y If 5 * x + 3 * y + z / 3 = 100 Then g = g & 公鸡 & x & ,母鸡 & y & ,小鸡 & z & Chr(10)End IfNext Next MsgBox (g)62、编写一个VBA程序，分解出给定整数的所有因子并输出。 k = InputBox(请输一整数：) g = k & = & Sgn(k) k = Abs(k)For i = 2 To k 2 Do While k Mod i = 0 g = g & * & i k = k i Loop NextIf k 1 Then g = g & * &k MsgBox g