【201401VBA初级】第四讲作业C组上交贴（已开帖）

xdragon · 发表于 2014-5-3 00:46

本帖最后由 xdragon 于 2014-5-10 16:48 编辑

第四讲作业下载地址：http://www.excelpx.com/thread-324104-1-1.html
第四讲视频下载地址：http://www.excelpx.com/thread-323949-1-1.html
本次作业提交要求如下：
1、提交请用代码形式提交，无需上传附件
2、所写代码的关键步骤需要注译（一段代码的作用说明），如不写注译扣5分
3、附件文件名或帖子标题按要求格式命名：组号-论坛ID,
如：C07-RxJc；
4、C组学员跟帖时，不要重复占楼，修改请在原楼层，本帖已设置回复仅作者可见；
5、非组学员勿跟帖，违者删帖处理；
6、作业截止时间：2014年5月6日，20:00，请准时交作业哈。

开心妙妙 · 发表于 2014-5-4 14:25

本帖最后由开心妙妙于 2014-5-5 18:13 编辑

C16:开心妙妙
暂时先交这些，第二题有时间再想想

Sub 第一题A()
Dim i&, i1 As Double, sum As Double, t As Single
t = Time
i = 1
Do
i1 = 1 / i '需要累加的值
sum = sum + i1 '累加值
i = i + 2 'i为分母作为循环步长
Loop While i1 > 10 ^ -7 '当i1大于10^-7,继续循环
MsgBox "sum:" & sum & Chr(10) & "运行时间:" & Time - t
End Sub
Sub 第一题B()
Dim i&, i1 As Double, sum As Double, t As Single
t = Time
For i = 1 To (10 ^ 7) + 2 Step 2
'分母作为循环值，步长为2,终值用10^7,1/10^7值和10^-7是相同的
'终值+2是因为步长为2,不加2的话到99就不循环,就无法循环最小值为10^-7
sum = sum + 1 / i '值累加
Next i
MsgBox "sum:" & sum & Chr(10) & "运行时间:" & Time - t '显示累加值及运行时间
End Sub
Sub 第二题()
Dim i&, st$, n As Byte
100:
i = Val(InputBox("请输入: " & Chr(10) & "大于等于1及小于等于16384的列号", "输入框")) '用Val将输入的数字转为数值
If Len(i) <> 0 And i > 0 And i < 16384 Then
st = Cells(1, i).Address(0, 0) '用Address 取单第1行第I列的单元格地址
st = Replace(st, "1", "") '用Replace将单元格地址行号1替换为""
MsgBox "列标是 : " & st, , "提示框"
Else
MsgBox "输入错误,请重新输入", 64
n = n + 1 '计算错误次数
If n > 3 Then
MsgBox "错误输入超过三次了,退出程序!", 64
Exit Sub
End If
GoTo 100
End If
End Sub
Sub 第三题()
Dim x%, y%, st$, n%
Dim Arr(1 To 11, 1 To 5) '定义数组 Arr(1 TO 11,1 TO 5)
For x = 1 To 11 '行循环
For y = 1 To 5 '列循环
If x <= 6 Then '判断如果 x<=6， 6是三角形顶点行的行号
If x + y - 1 = 6 Then '如果行+列-1=6 则等于"*"
Arr(x, y) = "*"
Else '否则等于" "
Arr(x, y) = " "
End If
st = st & " " & (Arr(x, y)) 'st=st & "" & (Arr(x,y)) '将数组的值连接到字符串
Else '如果x>6 的,用5,4,3,2,1的行号去加列号
n = x Mod 6 '行号 Mod 6,用余数计算行号的差值
If x - n * 2 + y - 1 = 6 Then '判断行号-行的差值+列号-1=6 则等于"*"
Arr(x, y) = "*"
Else '否则等于" "
Arr(x, y) = " "
End If
st = st & " " & (Arr(x, y)) 'st=st & "" & (Arr(x,y)) '将数组的值连接到字符串
End If
Next y
st = st & " " & "*" '最后1列固定不变的直接连接上"*"
Debug.Print st '立即窗口打印连接的字符串
st = "" '将字符串初始化
Next x
End Sub
Sub 第四题()
Dim i%, c% '定义行列变量
Dim Arr(1 To 4, 1 To 4), Arr1(1 To 4, 1 To 4) '定义原数组、目标数组大小
For i = 1 To 4 '行循环
For c = 1 To 4 '列循环
Arr(i, c) = Int((10 - 5 + 1) * Rnd() + 5)
'生成5-10的随机数赋值给数组,10表示最大值,5表示最小值
Next c
Next i
Range("A1").Resize(4, 4) = Arr
For c = 1 To 4 '列循环
For i = 1 To 4 '行循环
Arr1(c, i) = Arr(5 - i, c)
Next i
Next c
Range("F1").Resize(4, 4) = Arr1
End Sub
'Arr1(c, i) = Arr(5 - i, c) 实现位置转换的关键,原来的列转换为目标数据行
'赋值时行列变量互换,行列互换后,最大的行变成最小的列,用5-i去实现效果

复制代码

eaglexs · 发表于 2014-5-4 14:33

C04:eaglexs 第四次作业：

Option Explicit
Sub 第一题()
Dim sums As Double, k As Long
Do
sums = sums + 1 / (1 + 2 * k) '数值累加
k = k + 1
Loop Until 1 / (1 + 2 * k) < 10 ^ -7 '当该项数值小于10^-7时退出循环
Debug.Print sums, k
End Sub
Sub 第二题1() '截取单元格地址方法
Dim str As String, col As Integer
On Error Resume Next '错误跳过，当inputbox输入不是数字时跳过
col = InputBox("请输入列数（1-16384）")
If Err.Number > 0 Then MsgBox "请输入1—16384之间的整数！": Exit Sub '如果输入错误类型，则提示并退出
If col <= 0 Or col > 16384 Then MsgBox "请输入1—16384之间的整数！": Exit Sub '如果输入范围错误，则提示并退出
str = Left(Cells(1, col).Address(0, 0), Len(Cells(1, col).Address(0, 0)) - 1) '取输入值对应的列号
MsgBox col & "的列号是：" & str '输出
End Sub
Sub 第二题2() '循环方法
Dim col As Integer, x As Integer, y As Byte, str As String
On Error Resume Next
On Error Resume Next '错误跳过，当inputbox输入不是数字时跳过
col = InputBox("请输入列数（1-16384）")
If Err.Number > 0 Then MsgBox "请输入1—16384之间的整数！": Exit Sub '如果输入错误类型，则提示并退出
If col <= 0 Or col > 16384 Then MsgBox "请输入1—16384之间的整数！": Exit Sub '如果输入范围错误，则提示并退出
x = col
Do
y = x Mod 26 '取余
str = Chr(64 + y) & str '把余数转换为对应的大写字母，并合并
x = x \ 26 '把数值除以26后取整，并循环
Loop Until x = 0 '如果x=0则退出循环
MsgBox col & "的列号是：" & str '输出
End Sub
Sub 第三题()
Dim i As Byte
Do '打印上半部分，当i<6时继续循环
If i > 0 Then
Debug.Print Space(10 - 2 * i) & "*" & Space(2 * i - 1) & "*"
Else 'i=0，打印空格+一个“*”
Debug.Print Space(10) & "*"
End If
i = i + 1 '计数增加
Loop While i < 6
i = 5
Do While i > 0 '打印下半部分，当i>0时继续循环
i = i - 1 '计数减少
If i > 0 Then
Debug.Print Space(10 - 2 * i) & "*" & Space(2 * i - 1) & "*"
Else
Debug.Print Space(10) & "*"
End If
Loop
End Sub
Sub 第四题()
Dim i As Byte, j As Byte, su As Byte
Dim arr(1 To 4, 1 To 4) As Integer, brr(1 To 4, 1 To 4) As Integer
Randomize '初始化随机种子
For i = 1 To 4
For j = 1 To 4
su = Int(Rnd * 6) + 5 '取5-10之间的随机数
arr(i, j) = su 'arr数组赋值
brr(5 - j, i) = su 'brr数组实现左翻90°
Next
Next
Range("b7").Resize(4, 4) = arr '把数组写回单元格
Range("g7").Resize(4, 4) = brr
Columns("b:j").AutoFit '自动调整列宽
End Sub

复制代码

ghostcan · 发表于 2014-5-4 16:11

本帖最后由 ghostcan 于 2014-5-5 08:32 编辑

C01-ghostcan '多谢龙哥指点，已经全部自己检查了一下，并且把代码重新粘贴下来自己测试了，结果没有问题了，嘿嘿！你指导的简洁的写法我就不贴了...，再次感谢！

复制代码

Sub 第一题()
Dim num As Double, n As Long 'num 为小数型
n = 1 'n初始化
Do
num = num + 1 / n
n = n + 2
Loop Until 1 / n < 10 ^ -7 '循环结束条件
MsgBox num
End Sub

复制代码

Sub 第二题2()
Dim Inum$, n, OK As Boolean, str As String 'n 可能为整数小数
Do
Inum = InputBox("请输入一个整数", "输入提示") 'inputbox 返回值位string类型
n = Val(Inum) '转换输入内容
If n < 1 Or n > 16384 Or n Mod 1 > 0 Then
MsgBox "输入错误", vbCritical, "错误提醒" '循环确定输入的是一个符合要求的值
OK = False
Else
OK = True
End If
Loop Until OK
str = Cells(1, n).Address(0, 0)
MsgBox Left(str, Len(str) - 1) & "列"
End Sub

复制代码

Sub 第二题()
Dim Inum$, n, m%, i%, ii%, arr(), OK As Boolean, str$ 'n 可能为整数小数
Do
Inum = InputBox("请输入一个整数", "输入提示") 'inputbox 返回值位string类型
n = Val(Inum) '转换输入内容
If n < 1 Or n > 16384 Or n Mod 1 > 0 Then
MsgBox "输入错误", vbCritical, "错误提醒" '循环确定输入的是一个符合要求的值
OK = False
Else
OK = True
End If
Loop Until OK
Do '循环转换输入值位26进制
m = n Mod 26
If m = 0 Then
n = Int(n / 26) - 1
Else
n = Int(n / 26)
End If
i = i + 1
ReDim Preserve arr(1 To i)
arr(i) = m
Loop Until n = 0
For ii = UBound(arr) To 1 Step -1 '把对应26进制的值转换为字母
If arr(ii) = 0 Then
arr(ii) = "Z"
str = str & arr(ii)
Else
arr(ii) = Chr(arr(ii) + 64)
str = str & arr(ii)
End If
Next
MsgBox str & "列", vbOKOnly, "对应的列标是：" '输出
End Sub

复制代码

Sub 第三题()
Dim i As Byte, j As Byte '定义循环变量
For i = 1 To 11 '两层循环
For j = 1 To 11
If i <= 6 Then '通过图片找规律，确定条件
If j = 11 Then
Debug.Print "*"
Else
If 2 * i - 1 + j = 12 Then Debug.Print "*"; Else Debug.Print Space(1);
End If
Else
If j = 11 Then
Debug.Print "*"
Else
If 2 * (i - 6) + 1 = j Then Debug.Print "*"; Else Debug.Print Space(1);
End If
End If
Next
Next
End Sub

复制代码

Sub 第四题()
Dim arr(1 To 4, 1 To 4), brr(1 To 4, 1 To 4), i As Byte, j As Byte, m As Byte, n As Byte '定义两个4*4数组接收结果，我习惯性不定义数组类型...
For i = 1 To 4 '2维数组，2层循环
For j = 1 To 4
arr(i, j) = VBA.Int((10 - 5 + 1) * Rnd) + 5 '生成随机整数，[5-10]
Next
Next
For m = 1 To 4 '根据对应关系，循环得到转置结果
For n = 1 To 4
brr(m, n) = arr(n, 5 - m)
Next
Next
Sheets(2).[a1].Resize(4, 4) = arr '输出对应结果至单元格区域
Sheets(2).[f1].Resize(4, 4) = brr
End Sub

复制代码

yy183413821 · 发表于 2014-5-5 21:06

Sub vba1()
Dim sum As Double
Dim n As Double
n = 1
Do
sum = sum + 1 / n
n = n + 2
Loop Until 1 / n < 10 ^ -7
MsgBox sum & Chr(13) & n
End Sub

学委题太难了
难得我都不会

RxJc · 发表于 2014-5-6 19:52

C07-RxJc
缺了次，感觉少了很多很多，憋到Deadline,只憋出第一题~~

Sub test1()
Dim a As Long
Dim sum As Single
Dim item As Single
a = 1
item = 1 / a
Do While item > 0.0000001
sum = sum + item
a = a + 2
item = 1 / a
Loop
MsgBox ("最终结果：" & sum & " 最终项：" & item)
End Sub

复制代码

as0810114 · 发表于 2014-5-6 19:57

本帖最后由 as0810114 于 2014-5-6 21:58 编辑

Sub 第一题()
Dim i As Long, Esum As Double
Do While 1 / (2 * i + 1) > 10 ^ -7
i = i + 1
Esum = 1 / (2 * i - 1) + Esum
Loop
MsgBox Esum
End Sub
Sub 第二题()
Dim a As String
a = InputBox("请输入1至" & Columns.Count & "之间的正整数")
Select Case Val(a)
Case 703 To Columns.Count
      MsgBox Chr((a - 703) \ 26 ^ 2 + 65) & Chr((Int((a - 1) / 26) - 1) Mod 26 + 65) & Chr((a - 1) Mod 26 + 65)
Case 27 To 702
      MsgBox Chr(((a - 1) \ 26 + 64)) & Chr((a - 1) Mod 26 + 65)
Case 1 To 26
      MsgBox Chr(a + 64)
End Select
End Sub
Sub 第三题()
Dim arr(1 To 11, 1 To 6), i As Integer, j As Integer
For i = 1 To 11
For j = 1 To 6
      If j = Abs(6 - i) + 1 Or j = 6 Then
      arr(i, j) = "*"
      Else
      arr(i, j) = " "
      End If
Next
Next
For i = 1 To 11
Debug.Print Join(Application.Index(arr, i, 0))
Next
End Sub
Sub 第四题()
Dim arr(1 To 4, 1 To 4), brr(1 To 4, 1 To 4), i As Byte, j As Byte
Randomize
For i = 1 To 4
For j = 1 To 4
      arr(i, j) = Int(5 + 6 * Rnd())
Next
Next
Range("A10").Resize(4, 4) = arr()
For i = 1 To UBound(arr())
For j = 1 To UBound(arr())
      brr(i, j) = arr(j, 5 - i)
Next
Next
Range("A15").Resize(4, 4) = brr()
End Sub

Frankhao123 · 发表于 2014-5-6 19:58

没做出来

Sub 累加()
Dim i As Single '定义变量为单精度
Dim n As Long '定义变量为长整型
Do While n <= 10 ^ 7
If n >= 1 And 1 = n Mod 2 Then '变量n大于等于1且为奇数时,进行下一步
i = 1 + 1 / n
Exit Do
MsgBox i
End If
Loop
End Sub

复制代码

开心妙妙 · 发表于 2014-5-6 20:19

本帖最后由开心妙妙于 2014-5-6 20:37 编辑

我帮你 · 发表于 2014-5-6 21:08

第一题
Sub t1()
Dim x As Double
Dim n As Long
x = 0
n = 1
Do While 1 / n >= 10 ^ -7
x = x + 1 / n
n = n + 2
Loop
MsgBox ("结果为：" & x)
End Sub
第二题
Sub t2()
Dim i As Integer
Dim s As String
i = InputBox("请输入数字：")
If i > 0 And i < 16385 Then
s = VBA.Split(Cells(1, i).Address, "$")(1)
Debug.Print (s)
Else
MsgBox "请重新输入"
End If
End Sub

复制代码

		自动登录	找回密码
密码			注册

[习题] 【201401VBA初级】第四讲作业C组上交贴（已开帖）

相关帖子

点评

评分

点评

评分

点评

评分

点评

评分

点评

评分

评分

点评

评分

点评

评分

浏览过的版块