vb算法数组实例

1.互不相等的随机数的生成算法

P rivate Sub CmdStart_Click()

'生成10个[1,100]范围内互不相等的随机整数

Dim R(1 To 10) As Integer '保存生成的10个数

Dim i As Integer, j As Integer

i = 1

Do While i <= 10

'生成一个随机数，并保存在r(i)中

R(i) = Int(Rnd * 100) + 1

'将r(i)与已经生成的r(1)~r(i-1)进行比较

For j = 1 To i - 1

If R(i) = R(j) Then Exit For

Next j

If j >= i Then 'j>=i说明r(i)没有与r(1)~r(i-1)的任何一个数相等

i = i + 1 'i加1，下一次生成新的，否则，i保持原值，下一次重新生成r(i)

End If

Loop

For i = 1 To 10

Print R(i);

Next i

Print

End Sub

2.选择排序

Private Sub CmdOrder1_Click()

Form1.Cls

Const N = 10

Dim A(1 To N) As Integer

Dim i As Integer, j As Integer, k As Integer

'生成并输出10个[1,100]范围内互不相等的随机整数

Print " 系统生成数据：";

i = 1

Do While i <= N

A(i) = Int(Rnd * 100) + 1

For j = 1 To i - 1

If A(i) = A(j) Then Exit For

Next j

If j >= i Then

Print A(i);

i = i + 1

End If

Loop

Print

'开始排序

For i = 1 To N - 1

'将a(i)与a(i+1)~a(N)每一个数进行比较

For j = i + 1 To N

If A(i) < A(j) Then '如果a(i)

temp = A(i)

A(i) = A(j)

A(j) = temp

End If

Next j

'输出第i轮排序的结果——找到a(i)~a(N)中的最大数，并放在a(i)中 Print "第" & i & "轮排序结果：";

For k = 1 To N

Print A(k);

Next k

Print

Next i

End Sub

3.选择排序优化：

Private Sub CmdOrder2_Click()

Form1.Cls

Const N = 10

Dim A(1 To N) As Integer

Dim i As Integer, j As Integer, k As Integer, Pos As Integer

'生成并输出10个[1,100]范围内互不相等的随机整数

Print " 系统生成数据：";

i = 1

Do While i <= N

A(i) = Int(Rnd * 100) + 1

For j = 1 To i - 1

If A(i) = A(j) Then Exit For

Next j

If j >= i Then

Print A(i);

i = i + 1

End If

Loop

Print

'开始排序

For i = 1 To N - 1

'寻找a(i)~a(N)中的最大数的下标，并保存在变量Pos中

Pos = i

For j = i + 1 To N

If A(Pos) < A(j) Then Pos = j

Next j

'如果Pos<>i,交换a(i),a(pos)

If Pos <> i Then

temp = A(i)

A(i) = A(Pos)

A(Pos) = temp

End If

'输出第i轮排序的结果

Print "第" & i & "轮排序结果：";

For k = 1 To N

Print A(k);

Next k

Print

Next i

End Sub

4.冒泡排序及其优化

Private Sub CmdOrder3_Click()

Form1.Cls

Const N = 10

Dim A(1 To N) As Integer

Dim i As Integer, j As Integer, k As Integer, Pos As Integer

'生成并输出10个[1,100]范围内互不相等的随机整数

Print " 系统生成数据：";

i = 1

Do While i <= N

A(i) = Int(Rnd * 100) + 1

For j = 1 To i - 1

If A(i) = A(j) Then Exit For

Next j

If j >= i Then

Print A(i);

i = i + 1

End If

Loop

Print

'开始排序

For i = 1 To N - 1

'依次比较a(1)和a(2),a(2)和a(3),.....,a(N-i)和a(N-i+1)，如果前数<后数，交换

If A(j) < A(j + 1) Then

temp = A(j)

A(j) = A(j + 1)

A(j + 1) = temp

End If

Next j

'输出第i轮排序的结果——找到了a(1)~a(N-i+1)中的最小数，并放置在a(N-i+1) Print "第" & i & "轮排序结果：";

For k = 1 To N

Print A(k);

Next k

Print

Next i

'冒泡排序的冒泡方向可以从前往后，也可以从后往前，思路相似，代码略有差异

End Sub

5.冒泡排序优化：

P rivate Sub CmdOrder4_Click()

Form1.Cls

Const N = 10

Dim A(1 To N) As Integer

Dim i As Integer, j As Integer, k As Integer, Pos As Integer

Dim IsChanged As Boolean

'生成并输出10个[1,100]范围内互不相等的随机整数

Print " 系统生成数据：";

i = 1

Do While i <= N

A(i) = Int(Rnd * 100) + 1

For j = 1 To i - 1

If A(i) = A(j) Then Exit For

Next j

If j >= i Then

Print A(i);

i = i + 1

End If

Loop

Print

'开始排序

For i = 1 To N - 1

'利用变量ischanged来监视是否发生数据交换，如果没有交换，表示数据排序已经完成，可以提前推出

IsChanged = False

If A(j) < A(j + 1) Then

temp = A(j)

A(j) = A(j + 1)

A(j + 1) = temp

IsChanged = True

End If

Next j

'输出第i轮排序的结果——找到了a(1)~a(N-i+1)中的最小数，并放置在a(N-i+1) Print "第" & i & "轮排序结果：";

For k = 1 To N

Print A(k);

Next k

Print

If Not IsChanged Then Exit For

Next i

End Sub

6.数组中元素的插入

Private Sub CmdStart_Click()

Dim a() As Integer

ReDim a(1 To 10)

'生成原始数据a(1)~a(10)

Print "原始数据:";

For i = 1 To 10

a(i) = Int(Rnd * 100) + 1

Print a(i);

Next i

position = Val(InputBox("请选择插入数据的位置(1~11)"))

x = Val(InputBox("请输入数据"))

'为数组扩容

ReDim Preserve a(1 To 11)

'移动插入位置后面的数据，注意移动的顺序和所移动的数据，不要多移、少移

For i = 10 To position Step -1

a(i + 1) = a(i)

Next i

'插入数据

a(position) = x

'输出新的数据

Print

Print "新的数据:";

For i = 1 To 11

Print a(i);

Next i

Print

End Sub

7-1开始插入

Option Base 1

Option Explicit

Dim a() As Integer

Private Sub CmdStart_Click()

'函数说明：

'lbound(数组名):返回数组的下标下限

'ubound(数组名):返回数组的下标上限

Dim x As Integer, Pos As Integer, i As Integer

x = Val(InputBox("请输入准备插入数组的数据"))

'为数组扩容

ReDim Preserve a(UBound(a) + 1)

'寻找数据x的插入位置pos——数组中第一个大于x的数据的位置 Pos = LBound(a)

Do While (a(Pos) <= x And Pos <= UBound(a) - 1)

Pos = Pos + 1

Loop

'移动插入位置后面的数据

For i = UBound(a) To Pos + 1 Step -1

a(i) = a(i - 1)

Next i

'插入数据

a(Pos) = x

'输出新的数据

Print

Print "新的数据:";

For i = LBound(a) To UBound(a)

Print a(i);

Next i

Print

End Sub

7-2生成数据并排序

Private Sub Command1_Click()

ReDim a(10)

Dim i As Integer, j As Integer, Pos As Integer

Dim Temp As Integer

'生成原始数据a(1)~a(10)

For i = 1 To 10

a(i) = Int(Rnd * 100) + 1

Next i

'排序

For i = 1 To 9

Pos = i

For j = i + 1 To 10

If a(Pos) > a(j) Then Pos = j

Next j

If Pos <> i Then

Temp = a(Pos): a(Pos) = a(i): a(i) = Temp

End If

Next i

Print "原始有序数据:";

For i = 1 To 10

Print a(i);

Next i

Print

End Sub

8.数组中元素的删除

先随机生成数据：Private Sub Command1_Click()

ReDim a(10)

Dim i As Integer, j As Integer, pos As Integer

Dim Temp As Integer

'生成原始数据a(1)~a(10)

Print "原始数据:";

For i = 1 To 10

a(i) = Int(Rnd * 100) + 1

Print a(i);

Next i

Print

End Sub

Option Base 1

Option Explicit

Dim a() As Integer

Private Sub CmdStart_Click()

'函数说明：

'lbound(数组名):返回数组的下标下限

'ubound(数组名):返回数组的下标上限

Dim x As Integer, pos As Integer, i As Integer

x = Val(InputBox("请输入准备删除的数据"))

'查找需要删除的数据是否存在

For pos = LBound(a) To UBound(a)

If a(pos) = x Then Exit For

Next pos

If pos > UBound(a) Then '需要删除的数据不存在

MsgBox "需要删除的数据不存在，删除动作立即停止！", vbOKOnly + vbCritical

Else

'通过移动数据达到删除数据的目的

For i = pos To UBound(a) - 1

a(i) = a(i + 1)

Next i

'数组缩容

ReDim Preserve a(UBound(a) - 1)

'输出新的数据

Print

Print "新的数据:";

For i = LBound(a) To UBound(a)

Print a(i);

Next i

Print

End If

End Sub

9.顺序查找法

Private Sub CmdStart_Click()

'函数说明：

'lbound(数组名):返回数组的下标下限

'ubound(数组名):返回数组的下标上限

Dim x As Integer, pos As Integer, i As Integer

x = Val(InputBox("请输入查找的数据"))

pos = LBound(a)

Do While pos <= UBound(a)

If a(pos) <> x Then

pos = pos + 1

Else

Exit Do

End If

Loop

If pos > UBound(a) Then '数据不存在

MsgBox "数据不存在！", vbOKOnly + vbInformation

Else

MsgBox "数据在数组中的下标是" & pos, vbOKOnly + vbInformation End If

End Sub

10.折半查找

Private Sub Command2_Click()

Dim x As Integer, l As Integer, r As Integer, m As Integer

x = Val(InputBox("请输入查找的数据"))

l = 1

r = 10

Do

m = (l + r) / 2

If a(m) > x Then

l = m + 1

ElseIf a(m) < x Then

r = m - 1

End If

Loop While (l <= r And a(m) <> x)

If a(m) = x Then

MsgBox "数据在数组中的下标是" & m, vbOKOnly + vbInformation

Else

MsgBox "数据不存在！", vbOKOnly + vbInformation

End If

'注：折半查找的查找效率高于顺序查找，但是需要以数据的有序性作为前提'实际应用中，排序并不需要每次都进行，排序值需要完成一次即可

'而且利用插入排序可以使得数据在输入完成的时候即可完成排序

End Sub

11.回文判断

法1：

Private Sub Command1_Click()

Dim s As String

s = Text1.Text

l = Len(s)

For i = 1 To l / 2

c1 = Mid(s, i, 1)

c2 = Mid(s, l - i + 1, 1)

If c1 <> c2 Then

Exit For

End If

Next i

If i <= l / 2 Then

Label2.Caption = "不是回文！"

Else

Label2.Caption = "是回文！"

End If

End Sub

法2

Private Sub Command2_Click()

Dim s() As String

St = Text1.Text

l = Len(St)

ReDim s(1 To l)

For i = 1 To l

s(i) = Mid(St, i, 1)

Next i

For i = 1 To l / 2

If s(i) <> s(l - i + 1) Then

Exit For

End If

Next i

If i <= l / 2 Then

Label2.Caption = "不是回文！"

Else

Label2.Caption = "是回文！"

End If

End Sub

12.矩阵的转置：

Option Base 1

Option Explicit

Private Sub Command1_Click()

Const N = 5

Dim a(N, N) As Integer, temp As Integer Dim i As Integer, j As Integer

'生成并输出数据

Print "转置前"

For i = 1 To 5

For j = 1 To 5

a(i, j) = Int(Rnd * 100)

Print a(i, j);

Next j

Print

Next i

'矩阵转置

For i = 1 To 5

For j = 1 To i - 1

temp = a(i, j)

a(i, j) = a(j, i)

a(j, i) = temp

Next j

Next i

'输出转置后的矩阵

Print "转置后"

For i = 1 To 5

For j = 1 To 5

Print a(i, j);

Next j

Print

Next i

end Sub

13.矩阵的乘法运算(P72例3-24）：

Option Base 1

Option Explicit

Dim a(5, 3) As Integer, b(3, 4) As Integer, c(5, 4) As Integer 1.生成矩阵A:

Private Sub Command1_Click()

Dim i As Integer, j As Integer

'生成并输出矩阵A

Print "矩阵A："

For i = 1 To 5

For j = 1 To 3

a(i, j) = Int(Rnd * 10)

Print a(i, j);

Next j

Print

Next i

End Sub

2.生成矩阵B

Private Sub Command2_Click()

Dim i As Integer, j As Integer

'生成并输出矩阵A

Print "矩阵B："

For i = 1 To 3

For j = 1 To 4

b(i, j) = Int(Rnd * 10)

Print b(i, j);

Next j

Print

Next i

End Sub

3.矩阵相乘：

Private Sub Command3_Click()

Dim i As Integer, j As Integer, k As Integer

Print "A*B"

For i = 1 To 5

For j = 1 To 4

'计算c(i,j)=a(i,1)*b(1,j)+a(i,2)*b(2,j)+a(i,3)*b(3,j)

c(i, j) = 0

For k = 1 To 3

c(i, j) = c(i, j) + a(i, k) * b(k, j)

Next k

Print c(i, j); Spc(7 - Len(Str(c(i, j))));

Next j

Print

Next i

End Sub

14.矩阵鞍点的查找（所在行最小，同时是所在列最大的元素）

附：某些特殊矩阵元素的特征描述（上三角、下三角、对角线元素等）

Option Base 1

Option Explicit

Private Sub Command3_Click()

Dim a(4, 5) As Integer

Dim i As Integer, j As Integer, k As Integer

Form1.Cls

Print "原始矩阵"

For i = 1 To 4

For j = 1 To 5

a(i, j) = Int(Rnd * 90) + 10

Print a(i, j);

Next j

Print

Next i

'开始寻找鞍点，

'方法：针对第i行

'找出第i行中最小的元素的列号k

'查找k列的所有元素，是否存在大于a(i,k)的元素，如果不存在，可以确定为鞍点

For i = 1 To 4

'找出第i行中最小的元素的列号k

k = 1

For j = 2 To 5

If a(i, j) < a(i, k) Then k = j

Next j

'遍历第k列元素，确定是否存在大于a(i,k)的元素

For j = 1 To 4

If a(j, k) > a(i, k) Then Exit For

Next j

If j > 4 Then Print i, k, a(i, k)

Next i

End Sub

15.杨辉三角：

法1：

Private Sub Command1_Click()

'利用二维数组，是比较简单直观的做法

Dim a(20, 20) As Long '最大不超过20层

Dim N As Integer '用户输入的层数

N = Val(InputBox("请输入杨辉三角的层数"))

For i = 1 To N + 1

a(i, 1) = 1

a(i, i) = 1

Next i

'以下利用杨辉三角的特征计算出杨辉三角的数字，结果存放在二维数组中，结果如下'1

'1 2 1

'1 3 3 1

'1 4 6 4 1

'......

For i = 3 To N + 1

For j = 2 To N

a(i, j) = a(i - 1, j - 1) + a(i - 1, j)

Next j

Next i

'将二维数组的左下三角元素以杨辉三角的格式输出，每个数据占6位

Form1.Cls

For i = 1 To N + 1

Print Tab(30 - 3 * i);

For j = 1 To i

c = Trim(Str(a(i, j)))

Print c; Spc(6 - Len(c)); '由于不同的数据位数不同，所以要根据位数在后面补足空格，确保总共占6位

Next j

Print

Next i

End Sub

法2：

Private Sub Command2_Click()

'用一位数组事先数据的输出

'初始化数组a元素为1，1，1，1，1，1，1，1，1，1，……

'第0轮

'输出a(1)

'第1轮

'输出a(1)~a(2)

'第2轮：

'从a（2）~a（2），令a(i)=a(i)+a(i-1)，数组元素变为1，2，1，1，1，1，1，1，1，1，……

'输出a(1)~a(3)

'第3轮

'从a（3）~a（2），令a(i)=a(i)+a(i-1)，数组元素变为1，3，3，1，1，1，1，1，1，1，……

'输出a(1)~a(4)

'第4轮

'从a（4）~a（2），令a(i)=a(i)+a(i-1)，数组元素变为1，4，6，4，1，1，1，1，1，1，……

'输出a(1)~a(5)

'......

'第i轮

'从a（i）~a（2），令a(i)=a(i)+a(i-1)

'输出a(1)~a(i+1)

'......

Dim a(20) As Long

For i = 1 To 20

a(i) = 1

Next i

N = Val(InputBox("请输入杨辉三角的层数"))

Form1.Cls

For i = 0 To N

'计算a(i)~a(2)

For j = i To 2 Step -1

a(j) = a(j) + a(j - 1)

'由于step=-1 ，所以当i=0,1的时候，循环没有进行，因此第0,1轮没有赋值，只有后面的输出

Next j

'输出a(1)~a(i+1)

Print Tab(30 - 3 * i);

For j = 1 To i + 1

c = Trim(Str(a(j)))

Print c; Spc(6 - Len(c));

Next j

Print

Next i

End Sub

16.海盗船上的生存问题

Private Sub Command1_Click()

Dim a() As Integer

Dim N As Integer '总人数

Dim D As Integer '死亡数字

Dim Curp As Integer '当前轮到数数字的人

Dim Pnum As Integer '当前船上剩余的人数

Dim i As Integer '

Form1.Cls

N = Val(Text1.Text)

D = Val(Text2.Text)

ReDim a(N)

For i = 1 To N

a(i) = 1

Next i

Print "下海顺序:"

i = 0

Curp = 0

Pnum = N

Do

Curp = Curp + 1 '轮到下一个人数数

If (Curp > N) Then Curp = 1 '如果一轮数完，让第一个人数

If (a(Curp) = 1) Then i = i + 1 '下标为Curp的人如果还在船上，由他数下一个数

If (i = D) Then '如果数到死亡数字

a(Curp) = 0 '把当前数数人扔下海

Print Curp '输出当前扔下海的人

Pnum = Pnum - 1 '剩余人数减1

i = 0 '从头重新数

End If

Loop While (Pnum > 1)

'寻找安全位置

For i = 1 To N

If a(i) = 1 Then

Print "安全位置=" & i

Exit For

End If

Next i

End Sub