[原创]经典问题vba代码示例

f_qc

题目基本来自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

 

f_qc

'【程序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

f_qc

'【程序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

f_qc

'【程序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

f_qc

'【程序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

f_qc

'【程序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

f_qc

【程序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 '10<i<=20
   a3 = 0.05 '20<i<=40
   a4 = 0.03 '40<i<=60
   a5 = 0.015 '60<i<=100
   a6 = 0.01 '100<i
   i = 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

XUZHANCHENG

能够让大家更好的理解，各种语句以及如何思考，这是最重要的！！高手

f_qc

 很多人都不愿看一些基础的书，但其实如果真的学好vba的话，看一本vb的程序员手册是非常有好处的，基础的明白以后，示例代码才能有一定的启发效果

halfzx

收藏起来慢慢品