[接龙...]部分程序代码注释，目录更新20051222

Long_III · 发表于 2005-11-9 08:46

62、字典的应用。在200个“所在单位”里，随机选取20个单位，并统计随机单位出现的次数。

QPYuqQRW.rar (13 KB, 下载次数: 129)

Private Sub CommandButton1_Click() Dim i%, a%, m%, arr() '定义变量，％为整型变量 Dim s%, Yarr Dim ds '定义ds为字典

Set ds = CreateObject("scripting.dictionary") '设置一个新字典 Application.ScreenUpdating = False '关闭屏幕更新 t = 20 '随机取的总数 Yarr = Range("a2:a201") '用Yarr数组记录下200个单位

Randomize '初始化随机数 On Error Resume Next '在字典增加重复数值的时候会产生错误，用这句忽略错误 For a = 1 To t '只表示循环t次,a无实在意义 i = Int(Rnd * 200) + 1 '从1到200的随机数 ds.Add i, m + 1 '增加到字典里面去，记录i的值，及数组对应的位置 If Err.Number = 0 Then '假如增加的时候没有重复的话，则增加一次到数组里去 m = m + 1 ReDim Preserve arr(1 To 2, 1 To m) '重新定义一个二维的动态数组 arr(1, m) = Yarr(i, 1) '给数组赋值 arr(2, m) = 1 '第一次记录次数为1 Else s = ds(i) '如果增加的时候有重复的话，用s来取得原先记录进字典里的数组的位置，即早先的m+1 arr(2, s) = arr(2, s) + 1 '多增加1次它的次数 End If Err.Clear '清除错误 Next On Error GoTo 0 '下次出错的时候继续报错

Sheet1.[c2:d1000].ClearContents '清除c、d列2～1000行的值 Sheet1.[c2].Resize(m, 2) = Application.WorksheetFunction.Transpose(arr) '数组转置，赋值给单元格 End Sub

lj1226189 · 发表于 2005-11-10 14:52

如果一个镇在10天内有3例相同的传染病则该镇发生了传染病暴发！

Application.ScreenUpdating = False '关闭屏幕更新，2000版结尾不用复原 Dim i&, j&, c&, k&, p&, a3&, a2&, arr2(), arr3() '声明变量 p = [a65536].End(xlUp).Row '取得末尾行 arr = Range("a2:c" & p) '将原数据存入数祖 Range("a1:c" & p).Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B2"), Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:=xlGuess '按地名、病明、时间排序，注意对表按一定格式排序是一种非常实用的方法，经常能化繁为简，提高效率 arr1 = Range("a2:c" & p) '将排序后的表存入另一个数祖 ReDim arr2(1 To p - 1, 1 To 4), arr3(1 To p - 1, 1 To 3) '重新定义2个数组用于存放发病情况和发病明细 i = 1: q = 1: n = 1 a3 = 1: a2 = 1 '设定循环中的变量初值 Do While i < p - 2 '数组共p-1行，而末尾2行数据不可能组成符合条件的行，因为满足条件至少需要连续3行记录，所以i只需要循环到p-3 If arr1(i, 1) = arr1(i + 2, 1) And arr1(i, 2) = arr1(i + 2, 2) And arr1(i + 2, 3) - arr1(i, 3) < 11 Then '因为数据行按升序排列，所以该if语句用于判断符合爆发条件的地区和疾病，注意arr1(i + 2, 3)-arr1(i, 3)<11决定i只需要判断到p-3即可 For j = i To 1 Step -1 '满足爆发条件的话可循着该记录向前找到该地区（疾病）的首记录，用于确定初始时间和病例数 If arr1(j, 1) = arr1(i, 1) And arr1(j, 2) = arr1(i, 2) Then '这是判断的条件 q = j '首记录行数 Else Exit For '找到即退出循环 End If Next j For n = q To p - 1 '该循环用于查找满足爆发条件的地区（疾病）的末记录.同时对数组赋值 If arr1(n, 1) = arr1(n + 1, 1) And arr1(n, 2) = arr1(n + 1, 2) Then '记录疾病明细数据 arr3(a3, 1) = arr1(n, 1) '地区 arr3(a3, 2) = arr1(n, 2) '疾病 arr3(a3, 3) = arr1(n, 3) '发病时间 a3 = a3 + 1 '增加记录标记 Else '一旦不满足条件可判断该记录已为末记录 arr3(a3, 1) = arr1(n, 1) '明细数据 arr3(a3, 2) = arr1(n, 2) '明细数据 arr3(a3, 3) = arr1(n, 3) '明细数据 a3 = a3 + 1 x1 = arr1(q, 3) '始发生时间 x2 = arr1(n, 3) '末发生时间 arr2(a2, 1) = arr1(n, 1) '发病情况 arr2(a2, 2) = arr1(n, 2) '发病情况 arr2(a2, 3) = n - j '病例数 arr2(a2, 4) = x1 & "至" & x2 '时间范围 a2 = a2 + 1 '增加记录标记 Exit For '找到末记录自然对出循环 End If Next n i = n + 1 '找到满足条件的记录则跳到另一个地区（疾病），避免了重复记数 End If i = i + 1 '未满足条件则判断下一记录 Loop '循环i Range("a2:c" & p) = arr '复原排序前的数据 Sheets("发病情况").Range("a2:d" & p) = arr2 '输出发病情况 Sheets("发病明细").Range("a2:c" & p) = arr3 '输出发病明细 '---END---

oa5r7C2T.rar (10.88 KB, 下载次数: 98)

lj1226189 · 发表于 2005-11-10 15:40

8pdknuaN.rar (36.85 KB, 下载次数: 120)

一种是数组一种不是数组大家可以明显感觉两者差异！

Private Sub CommandButton1_Click() Dim i, j As Integer Dim f As Boolean For i = 2 To 2429 f = False For j = 2 To 16 If InStr(Sheet1.Cells(i, 1), Sheet1.Cells(j, 4)) <> 0 Then f = True: Exit For Next j If f = True Then Sheet1.Cells(i, 3) = Sheet1.Cells(j, 4) Else Sheet1.Cells(i, 3) = "其它" End If Next i

End Sub

'数组的起始位置为0，如果你没注明的话，这样你ReDim arr2(1 To 2428, 1)，就是两列了，从0 到1 Private Sub CommandButton2_Click() Dim i, j, q As Integer Dim f As Boolean Dim arr, arr1, arr2() Application.ScreenUpdating = False arr = Sheet1.Range("a2:a2429") arr1 = Sheet1.Range("d2:d16") ReDim arr2(1 To 2428, 0) For i = 1 To 2428 f = False For j = 1 To 15 If f = False And InStr(arr(i, 1), arr1(j, 1)) <> 0 Then f = True: Exit For Next j If f = True Then arr2(i, 0) = arr1(j, 1) Else arr2(i, 0) = "其它" End If Next i Sheet1.Range("c2:c2429") = arr2 End Sub

lj1226189 · 发表于 2005-11-11 10:33

将要查找并替换的值一起录入到两列中，点击按钮2000多条记录查找并替换在不到1秒钟之内完成！ 5AQQDUJu.rar (30.89 KB, 下载次数: 122)

Private Sub CommandButton2_Click() Dim i, j, q As Integer Dim f As Boolean Dim arr, arr1, arr2() Application.ScreenUpdating = False arr = Sheet1.Range("a2:a2429") arr1 = Sheet1.Range("d2:e16") ReDim arr2(1 To 2428, 0) For i = 1 To 2428 f = False For j = 1 To 15 If f = False And InStr(arr(i, 1), arr1(j, 1)) <> 0 Then f = True: Exit For Next j If f = True Then arr(i, 1) = Replace(arr(i, 1), arr1(j, 1), arr1(j, 2))

End If Next i Sheet1.Range("a2:a2429") = arr End Sub

[此贴子已经被作者于2005-11-11 15:00:53编辑过]

zysun · 发表于 2005-11-11 11:26

太好了,伟大的人呀,

Long_III · 发表于 2005-11-15 10:25

63、[glow=255,blue,2]多条件求和。排序+动态数组。[/glow]这是一个很重要的提速的方法，希望初学者仔细看，一定要掌握这种方法哦。代码不附了，里面有详细的备注。 iCAHVb4Z.rar (19.6 KB, 下载次数: 234)

【个人认为，本部分的三个例子，是数组中很重要的一部分】

[此贴子已经被作者于2005-11-15 13:04:41编辑过]

Long_III · 发表于 2005-11-17 14:26

64、字典的运用2。统计重复、次数等，用字典处理之后，速度奇快。里面的问题是，统计四列数里的重复情况

4GNVtuqT.rar (27.88 KB, 下载次数: 200)

紫蝶儿菲菲 · 发表于 2005-11-17 14:32

请问一下：得到的ABCD、.......数据是代表在A、B、C、D列出现过的意思吗？

浩月 · 发表于 2005-11-17 22:56

请帮注解,多谢!

Private Sub Worksheet_Activate()

End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range) 'On Error Resume Next With ComboBox1 If Target.Column = 2 And Target.Row > [StartRow].Row Then '激活控件 .Visible = True '设置控件位置、大小 .Top = ActiveCell.Top .Left = ActiveCell.Left .Height = ActiveCell.Rows.Height .Width = ActiveCell.Columns.Width + 14 '设置控件边框、底色 .BorderStyle = fmBorderStyleNone .BackColor = RGB(200, 220, 240) '设定列表数据源 .ListFillRange = "Data" .BoundColumn = 1 '返回第一列数据 '设定列表表格属性 .ListRows = 20 .ColumnCount = 7 '确定列表列数 .ColumnWidths = "70; 270; 50; 60; 60; 60" .ListWidth = 650 .TextAlign = fmTextAlignCenter '数据放置列中心 .ColumnHeads = True '有列标题 .TextColumn = 1 '选定第一列 '返回数据到单元格 .LinkedCell = Target.Address Else .Visible = False End If End With End Sub

Private Sub ComboBox1_Change() Dim i If ActiveCell.Column = 2 And ActiveCell.Row > [StartRow].Row Then With ActiveCell For i = .Row To .Row + .Rows.Count - 1 If Cells(i, 2).value = "" Then Cells(i, 3).value = "" Cells(i, 4).value = "" Cells(i, 7).value = "" Cells(i, 8).value = "" Cells(i, 9).value = "" Cells(i, 12).value = "" Cells(i, 13).value = "" Cells(i, 14).value = "" Else Cells(i, 3).value = "=项目名称" Cells(i, 3) = Cells(i, 3).value Cells(i, 4).value = "=单位" Cells(i, 4) = Cells(i, 4).value Cells(i, 7).value = "=合计" Cells(i, 7) = Cells(i, 7).value Cells(i, 8).value = "=人工费" Cells(i, 8) = Cells(i, 8).value Cells(i, 9).value = "=机械费" Cells(i, 9) = Cells(i, 9).value Cells(i, 12).value = "=" & Cells(i, 5).Address(False, True, xlA1) & "*" & Cells(i, 7).Address(False, False, xlA1) Cells(i, 13).value = "=" & Cells(i, 5).Address(False, True, xlA1) & "*" & Cells(i, 8).Address(False, False, xlA1) Cells(i, 14).value = "=" & Cells(i, 5).Address(False, True, xlA1) & "*" & Cells(i, 9).Address(False, False, xlA1) End If Next i End With End If End Sub

浩月 · 发表于 2005-11-17 22:59

Sub ch() For Each c In Worksheets Rem c.Visible = True Next c End Sub 是何解?

kWD3k4HC.rar (39.61 KB, 下载次数: 53)

[此贴子已经被作者于2005-11-17 23:00:46编辑过]

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

[接龙...]部分程序代码注释，目录更新20051222

UNARTHUR大师的力作！数组排序后的又一用！

两种方法！搜索一组数据中是否包含另一组数据中某文本，并显示该文本

在某列中成批查找并替换！