如何在EXCEL内实现录入、保存、查看并实现计算？

excelxuesheng

附件.rar (13.02 KB, 下载次数: 41)

2013-2-23 14:55 上传

点击文件名下载附件

如何做到呢？我想只有我们的论坛高手才能做到吧。哪位高手出手一下，先谢了！

amesman

要求描述不清。。。

蓝桥玄霜

1. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
   
2. Dim rng As Range, cx$, c%, Arr, i&, n&, ks, js, c1%
   
3. Set rng = [c3:i3]
   
4. If Target.Count > 1 Then Exit Sub
   
5. If Intersect(rng, Target) Is Nothing Then Exit Sub
   
6. [a8:ab22].ClearContents
   
7. ks = DateSerial([c2].Value, [e2].Value, 1)
   
8. js = DateSerial([h2].Value, [j2].Value + 1, 1) - 1
   
9. cx = Target.Value
   
10. Select Case cx
    
11.     Case "出生"
    
12.         c1 = 18
    
13.     Case "人流"
    
14.         c = 14: c1 = 15
    
15.     Case "放环", "结扎", "取环"
    
16.         c = 20: c1 = 22
    
17.     Case "结婚"
    
18.         c = 6: c1 = 8
    
19.     Case "死亡"
    
20.         c = 24: c1 = 25
    
21. End Select
    
22. Arr = Sheet1.[a1].CurrentRegion: n = 7
    
23. For i = 6 To UBound(Arr)
    
24.     If c1 = 18 Then
    
25.         If Arr(i, c1) <> "" Then
    
26.             rq = DateSerial(Left(Arr(i, c1), 4), Mid(Arr(i, c1), 5, 2), Right(Arr(i, c1), 2))
    
27.             If rq >= ks And rq <= js Then
    
28.                 n = n + 1
    
29.                 Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, i, 0)
    
30.             End If
    
31.         End If
    
32.     ElseIf c <> 6 Then
    
33.         If Arr(i, c) = cx Then
    
34.         If Arr(i, c1) <> "" Then
    
35.             rq = DateSerial(Left(Arr(i, c1), 4), Mid(Arr(i, c1), 5, 2), Right(Arr(i, c1), 2))
    
36.             If rq >= ks And rq <= js Then
    
37.             n = n + 1
    
38.             Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, i, 0)
    
39.         End If
    
40.         End If
    
41.         End If
    
42.     Else
    
43.         If InStr(Arr(i, c), "婚") > 0 Then
    
44.         If Arr(i, c1) <> "" Then
    
45.             rq = DateSerial(Left(Arr(i, c1), 4), Mid(Arr(i, c1), 5, 2), Right(Arr(i, c1), 2))
    
46.             If rq >= ks And rq <= js Then
    
47.             n = n + 1
    
48.             Cells(n, 1).Resize(1, UBound(Arr, 2)) = Application.Index(Arr, i, 0)
    
49.         End If
    
50.         End If
    
51.         End If
    
52.     End If
    
53. Next
    
54. If n = 7 Then MsgBox "没有符合条件的数据。"
    
55. End Sub
    

复制代码

蓝桥玄霜

请见附件。

excelxuesheng

蓝桥玄霜 发表于 2013-2-23 18:19
请见附件。

真心谢谢了

excelxuesheng

蓝桥玄霜 发表于 2013-2-23 18:19
请见附件。

谢谢了，正月十五快乐。

excelxuesheng

蓝桥玄霜 发表于 2013-2-23 18:19
请见附件。

正解，谢谢了

蓝桥玄霜

注意有日期时段的判断。

excelxuesheng

蓝桥玄霜 发表于 2013-2-24 09:16
注意有日期时段的判断。

好，很好。再烦您再看个这个附件 报表累计0223.rar (14.44 KB, 下载次数: 23)

2013-2-24 10:33 上传

点击文件名下载附件

xsy我可以很好

向蓝版学习