[原创]经典问题vba代码示例[ExcelHome技术论坛]

经典问题vba代码示例题目基本来自c经典编程，用vba全部重新写了，可以作为代码的参考
‘【程序1】
 
 
‘题目：古典问题：有一对兔子，从出生后第3个月起每个月都生一对兔子，小兔子长到第三个月
 
 
‘后每个月又生一对兔子，假如兔子都不死，问每个月的兔子总对数为多少？
 
 
‘1.程序分析：兔子的规律为数列1,1,2,3,5,8,13,21....
 
 
‘2.程序代码
 
 
Sub prog1()
 
 
‘
 
 
Dim tuji, f(20)
 
 
n = 20
 
 
For i = 1 To 20
 
 
If i = 1 Then f(i) = 1
 
 
If i = 2 Then f(i) = 1
 
 
If i > 2 Then
 
 
f(i) = f(i - 1) + f(i - 2)
 
 
End If
 
 
Next
 
 
MsgBox CStr(f(20))
 
 
End Sub
‘ 【程序2】
 
 
‘题目：一个整数，它加上100后是一个完全平方数，再加上168又是一个完全平方数，请问该数是多少？
 
 
Sub prog2()
 
 
‘
 
 
Dim jilu(100), strjilu
 
 
j = 1
 
 
For i = 1 To 100
 
 
jilu(i) = 0
 
 
Next i
 
 
For i = 1 To 10000
 
 
If Sqr(i + 100) = Int(Sqr(i + 100)) Then
 
 
If Sqr(i + 268) = Int(Sqr(i + 268)) Then
 
 
jilu(j) = i
 
 
j = j + 1
 
 
‘MsgBox "该数为" & CStr(i)
 
 
‘Exit For
 
 
End If
 
 
End If
 
 
Next
 
 
If jilu(1) = 0 Then
 
 
MsgBox "meiyou"
 
 
Else
 
 
For i = 1 To 100
 
 
If jilu(i) <> 0 Then
 
 
strjilu = strjilu + "||" + CStr(jilu(i))
 
 
End If
 
 
Next
 
 
MsgBox "该数为" & strjilu
 
 
End If
 
 
End Sub
 
 
 
【程序3】
‘题目：输入两个正整数m和n，求其最大公约数和最小公倍数。
Sub prog3()
‘
Dim m, n
m = 30: n = 14
If m = n Then
beishu = m
yueshu = m
ElseIf m > n Then
For i = n To 1 Step -1
If (m Mod i = 0) And (n Mod i = 0) Then
yueshu = i
Exit For
End If
Next
j = m
tt = 0
Do While (tt = 0)
j = j + 1
If (j Mod m = 0) And (j Mod n = 0) Then
beishu = j
tt = 1
End If
Loop
End If
MsgBox "beishu" & CStr(beishu) & "  " & "yueshu" & CStr(yueshu)
End Sub
‘【程序4】
‘题目：一个数如果恰好等于它的因子之和，这个数就称为“完数”。例如6=1＋2＋3.编程找出100以内的所有完数?
‘对n进行分解质因数，应先找到一个最小的质数k，然后按下述步骤完成：
‘(1)如果这个质数恰等于n，则说明分解质因数的过程已经结束，打印出即可。
‘(2)如果n<>k，但n能被k整除，则应打印出k的值，并用n除以k的商,作为新的正整数n,重复执行第一步
‘(3)如果n不能被k整除，则用k+1作为k的值,重复执行第一步。
Sub prog4()
‘
Dim a(20)
n = 1
m = 1
For i = 1 To 100
‘
k = 1
a(1) = 1
For j = 2 To 20
a(j) = 0
Next
l = i
pp = True
‘寻找数的因子
Do While pp
If l = 1 Then
Exit Do
End If
For j = 2 To l
If l Mod j = 0 Then
a(k) = j
k = k + 1
l = l / j
Exit For
End If
Next
Loop
‘求各因子的和
s = 0
For j = 1 To 20
s = s + a(j)
Next
‘判断是否相等
If (s + 1) = i Then
Sheet2.Cells(n, 3) = i
n = n + 1
‘Exit For
End If
‘
For j = 1 To 20
If a(j) <> 0 Then
Sheet2.Cells(m, 4) = 1
Sheet2.Cells(m, j + 4) = a(j)
Else
Exit For
End If
Next
m = m + 1
Next
End Sub
【程序5】
‘题目：一球从100米高度自由落下，每次落地后反跳回原高度的一半；再落下，求它在第10次落地时，共经过多少米？第10次反弹多高？
Sub prog5()
‘
Dim fantai(10)
fantai(1) = 100
For i = 2 To 10
fantai(i) = fantai(i - 1) / 2
Next
s = 0
For i = 1 To 10
s = s + fantai(i)
Next
MsgBox "共经过" & CStr(s) & "米;第10次反弹" & CStr(fantai(10))
End Sub
‘【程序6】
‘题目：猴子吃桃问题：猴子第一天摘下若干个桃子，当即吃了一半，还不过瘾，又多吃了一个第二天早上又将剩下的桃子吃掉一半，
‘又多吃了一个。以后每天早上都吃了前一天剩下的一半零一个。到第10天早上想再吃时，见只剩下一个桃子了。求第一天共摘了多少。
Sub prog6()
‘
Dim taozi(10)
For i = 10 To 1 Step -1
If i = 10 Then
taozi(i) = 1
Else
taozi(i) = (taozi(i + 1) + 1) * 2
End If
Next
MsgBox CStr(taozi(1))
End Sub
【程序7】
‘题目：编写一个函数，输入n为偶数时，调用函数求1/2+1/4+...+1/n,当输入n为奇数时，调用函数
‘1/1+1/3+...+1/n(利用指针函数)
Sub prog7()
‘
n = 12
s = 0
If n Mod 2 = 0 Then
For i = 2 To n Step 2
s = s + 1 / i
Next
Else
For i = 1 To n Step 2
s = s + 1 / i
Next
End If
MsgBox CStr(s)
End Sub
 
‘【程序8】
‘题目：海滩上有一堆桃子，五只猴子来分。第一只猴子把这堆桃子凭据分为五份，多了一个，这只
‘猴子把多的一个扔入海中，拿走了一份。第二只猴子把剩下的桃子又平均分成五份，又多了
‘一个，它同样把多的一个扔入海中，拿走了一份，第三、第四、第五只猴子都是这样做的，
‘问海滩上原来最少有多少个桃子？
Sub prog8()
‘
j = 1
For i = 1 To 10000
If (i - 1) Mod 5 = 0 Then ‘1只猴子分
t1 = (i - 1) * 4 / 5
If (t1 - 1) Mod 5 = 0 Then ‘2只猴子分
t2 = (t1 - 1) * 4 / 5
If (t2 - 1) Mod 5 = 0 Then ‘3只猴子分
t3 = (t2 - 1) * 4 / 5
If (t3 - 1) Mod 5 = 0 Then ‘4只猴子分
t4 = (t3 - 1) * 4 / 5
If (t4 - 1) Mod 5 = 0 Then ‘5只猴子分
Sheet1.Cells(j, 1) = i
Sheet1.Cells(j, 2) = t1 / 4
Sheet1.Cells(j, 3) = t2 / 4
Sheet1.Cells(j, 4) = t3 / 4
Sheet1.Cells(j, 5) = t4 / 4
Sheet1.Cells(j, 6) = (t4 - 1) / 5
j = j + 1
‘If j = 21 Then Exit For
‘MsgBox "taozhi" & CStr(i)
‘Exit For
End If
End If
End If
End If
End If
Next
End Sub
【程序9】
‘题目：打印出所有的“水仙花数”，所谓“水仙花数”是指一个三位数，其各位数字立方和等于该数
‘本身。例如：153是一个“水仙花数”，因为153=1的三次方＋5的三次方＋3的三次方。
Sub prog9()
‘
m = 1
For i = 100 To 999
j = Int(i / 100)
k = Int((i - j * 100) / 10)
l = i - 100 * j - k * 10
If i = j ^ 3 + k ^ 3 + l ^ 3 Then
Sheet1.Cells(m, 8) = i
m = m + 1
End If
Next
End Sub
‘【程序10】
‘题目：求1+2!+3!+...+20!的和
Sub prog10()
‘
s = 0
For i = 1 To 20
t = 1
For j = 1 To i
t = t * j
Next
s = s + t
Next
MsgBox CStr(s)
End Sub
【程序11】
‘题目：一个5位数，判断它是不是回文数。即12321是回文数，个位与万位相同，十位与千位相同。
Sub prog11()
‘
j = 1
For i = 10000 To 99999
k = Int(i / 10000)
l = Int((i - k * 10000) / 1000)
m = CInt(Left((Right(CStr(i), 2)), 1))
n = CInt((Right(CStr(i), 1)))
If (k = n) And (l = m) Then
Sheet2.Cells(j, 1) = i
j = j + 1
End If
Next
End Sub
‘【程序12】
‘题目：判断101-200之间有多少个素数，并输出所有素数。
Sub prog12()
‘
k = 1
For i = 101 To 200
For j = 2 To Int(Sqr(i)) + 1
If i Mod j = 0 Then
Exit For
End If
Next
If j = Int(Sqr(i)) + 2 Then
Sheet2.Cells(k, 2) = i
k = k + 1
End If
Next
End Sub
【程序13】
‘题目：有1、2、3、4个数字，能组成多少个互不相同且无重复数字的三位数？都是多少？
Sub prog13()
‘
Dim a(4)
m = 0
‘m,n,o
For i = 1 To 4
a(i) = i
Next
For i = 1 To 4
For j = 1 To 4
For k = 1 To 4
If ((i <> k) And (i <> j)) And (j <> k) Then
m = m + 1
Sheet3.Cells(1, m + 1) = CStr(i) + CStr(j) + CStr(k)
End If
Next
Next
Next
Sheet3.Cells(1, 1) = m
End Sub
‘【程序14】
‘题目：企业发放的奖金根据利润提成。利润(I)低于或等于10万元时，奖金可提10%；利润高
‘于10万元，低于20万元时，低于10万元的部分按10%提成，高于10万元的部分，可可提
‘成7.5%；20万到40万之间时，高于20万元的部分，可提成5%；40万到60万之间时高于
‘40万元的部分，可提成3%；60万到100万之间时，高于60万元的部分，可提成1.5%，高于
‘100万元时，超过100万元的部分按1%提成，在sheet3(2,1)中输入月利润I，在sheet3(2,2)中求出发放奖金总数。
Sub prog14()
‘
a1 = 0.1 ‘i<=10
a2 = 0.075 ‘10a3 = 0.05 ‘20a4 = 0.03 ‘40a5 = 0.015 ‘60a6 = 0.01 ‘100i = Sheet3.Cells(2, 1)
bouns = 0
pp = True
Do While pp
If i > 100 Then
bouns = bouns + (i - 100) * a6
i = i - 100
ElseIf i > 60 And i <= 100 Then
bouns = bouns + (i - 60) * a5
i = i - 60
ElseIf i > 40 And i <= 60 Then
bouns = bouns + (i - 40) * a4
i = i - 40
ElseIf i > 20 And i <= 40 Then
bouns = bouns + (i - 20) * a3
i = i - 20
ElseIf i > 10 And i <= 20 Then
bouns = bouns + (i - 10) * a2
i = i - 10
ElseIf i <= 10 Then
bouns = bouns + i * a1
Exit Do
End If
Loop
Sheet3.Cells(2, 2) = bouns
End Sub
在sheet3的代码输入处输入如下代码：
（我在调试时将所有的程序都放在sheet1中）
Private Sub Worksheet_Change(ByVal Target As Range)
‘
If Target = Cells(2, 1) Then
Sheet1.prog14
End If
End Sub
‘【程序15】
‘题目：有一分数序列：2/1，3/2，5/3，8/5，13/8，21/13...求出这个数列的前20项之和。
Sub prog15()
‘
Dim a(20), b(20)
a(1) = 2
b(1) = 1
s = a(1) / b(1)
For i = 2 To 20
a(i) = a(i - 1) + b(i - 1)
b(i) = a(i - 1)
s = s + a(i) / b(i)
Next
MsgBox CStr(s)
End Sub