99%=1%

  博客园  :: 首页  :: 新随笔  :: 联系 :: 订阅 订阅  :: 管理
通过excel vba 实现艾宾浩斯遗忘曲线的复习提醒

1、实现原理：

艾宾浩斯seid一个知识点学习后要复习8次后可达到永久记忆（这个还有待验证。。。），其复习间隔时间分别为1d、2d、4d、7d、15d、30d、90d、180d。

2、实现效果：

在一个sheet【学习清单】里按日期记录每天的学习内容（如图1），在另外一个sheet【当日复习清单】里提供日期选择功能，并根据选择日期切换显示当日需要复习的内容（如图2）。

 

图1：

 

 图2：

 

 3、用到的知识点：

3.1 二分查找算法：

随着记录的学习内容渐渐多，需要节省查找时间。使用这个算法的前提是每天的学习内容是按日期升序排序的。

3.2 vba返回单元格的3种方式：

sheet1.range("b2:d4")；sheet1.cells(3,4)；sheet1.[a2:d6]。因为涉及不同sheet表之间的取值，所以需要标明sheet页名称。

3.3 返回一列单元格有数据的最后一行：

Worksheets("学习清单").Range("a1048576").End(3).Row

Range("a1048576").End(3) 代表从 a1048576单元格往前查找到的第一个有数据的单元格。
Range("a1048576").End(3).Row 表示A列单元格最下面一个有数据的单元格的行号。

End(3)这个3代表常量 xlup，表示向上搜索。
2003版本后一张Excel工作表，最多可以包括1048576行和16384列。

3.4 vba中实现数值改变单元格后触发事件：

假设要判断的值在A1，则代码为：
Dim oldval
Private Sub Worksheet_Activate()
    oldval = [a1]
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
    If oldval <> [a1] Then
        oldval = [a1]
        '在此输入操作代码
    End If
End Sub

4、全部vba代码如下：

 1 Dim date_select '选择的复习日期
 2 Dim array_a(8) '存储复习间隔，共8个间隔
 3 
 4 Private Sub Worksheet_Activate()
 5     date_select = Worksheets("当日复习清单").[b1]
 6     array_a(8) = 1
 7     array_a(7) = 2
 8     array_a(6) = 4
 9     array_a(5) = 7
10     array_a(4) = 15
11     array_a(3) = 30
12     array_a(2) = 90
13     array_a(1) = 180
14 End Sub
15 Private Sub Worksheet_Change(ByVal Target As Range)
16     If date_select <> Worksheets("当日复习清单").[b1] Then
17         date_select = Worksheets("当日复习清单").[b1]
18         Worksheets("当日复习清单").[a4:d1048576] = ""
19         
20         Dim array_b(8) '存储所选择的复习日期对应的学习日期，共8个
21         Dim hang_all, hang_half '学习日期的有数据的最后行号和中间行号
22         Dim find_begin, find_end '查找学习日期时的开始行号和结束行号
23 
24         Dim hang_now '存储复习内容的长度，每次选择日期后会更新为0
25         hang_now = 0
26         
27         hang_all = Worksheets("学习清单").Range("a1048576").End(3).Row '返回一列单元格有数据的最后一行
28         hang_half = Int(hang_all / 2)
29         
30         For i = 1 To 8 '计算学习日期
31             array_b(i) = date_select - array_a(i)
32             
33             If Worksheets("学习清单").Cells(hang_half, 1) <= array_b(i) Then '利用二分查找算法提高查找效率
34                 Do While Worksheets("学习清单").Cells(hang_half, 1) = Worksheets("学习清单").Cells(hang_half - 1, 1)
35                     hang_half = hang_half - 1
36                 Loop '解决：中间行号的学习日期和前后日期相等的情况
37                 find_begin = hang_half
38                 find_end = hang_all
39                 Else
40                 Do While Worksheets("学习清单").Cells(hang_half, 1) = Worksheets("学习清单").Cells(hang_half + 1, 1)
41                     hang_half = hang_half + 1
42                 Loop '解决：中间行号的学习日期和前后日期相等的情况
43                 find_begin = 2
44                 find_end = hang_half
45             End If
46             
47             For j = find_begin To find_end '根据学习日期返回复习内容
48                 If Worksheets("学习清单").Cells(j, 1) = array_b(i) Then
49                     hang_now = hang_now + 1
50                     Worksheets("当日复习清单").Cells(hang_now + 3, 1) = hang_now
51                     Worksheets("当日复习清单").Cells(hang_now + 3, 2) = Worksheets("学习清单").Cells(j, 2) '复习内容
52                     Worksheets("当日复习清单").Cells(hang_now + 3, 3) = Worksheets("学习清单").Cells(j, 3) '时长
53                     Worksheets("当日复习清单").Cells(hang_now + 3, 4) = Worksheets("学习清单").Cells(j, 1) '学习日期
54                 End If
55             Next j
56             find_find = j '因为要找的学习日期是升序存储的，所以查找下一个学习日期时可以把查找的开始行号改为j
57         Next i
58         Dim time_sum
59         time_sum = Application.WorksheetFunction.Sum(Worksheets("当日复习清单").Range("c:c"))
60         Worksheets("当日复习清单").[a2] = "共需复习" & hang_now & "个内容，共需" & time_sum & "分钟"
61     End If
62 End Sub

 

posted on 2020-02-07 10:36  99%=1%  阅读(1477)  评论(0)    收藏  举报