幻影2000

remoteli

都是100% ？？？

恕我直言：你地在造假。

及时报卡率不会总是保持100%，从事多年疫情管理工作的，都明白这个道理。

我相信，实事求是做工作的地区占主流。

作为本主题回帖最多的帖子，你一句话就能否定吗？

如果，你有什么好的工作经验，请你不要吝啬，在这里和大家分享一下，要比这个有意义的多。

要是觉得这个东东没用，你告诉洋子，把这个帖子删掉就是了。当然，如果能把大疫情管理系统的报告质量评价取消掉，那是再好不过的了。

幻影2000

如果你有所顾虑，那么使用前按我的说明设置，不用的时候恢复默认设置。

说明一下：本表格不含有威胁安全的代码。

“宏”是微软办公套件提供的vba程序，可以大大提高办公效率。你不想体验一下吗？

幻影2000

VBA编程。

微软Office办公套件，内嵌了Basic语言。用VB编程，配合了函数、动态图标等制作为而成。

幻影2000

大疫情系统导出卡片新增“订正终审时间”（AD列），造成旧版统计表不能完成统计，现已更新。 有问题请发帖！不会设置宏安全性的，请运行“改变安全性.exe”

第二排按钮功能，如“14岁以下儿童无患儿家长姓名”等功能开发调试中...，个人精力有限，还请见谅。

下载请到1楼。

下载 (147.39 KB)
[原创]更新！传染病疫情报告信息质量综合评价

2008-5-1 08:58

幻影2000

呵呵，过奖，更希望各位高手一起完善程序。

动态图表部分表述过于繁琐，略过。

相关vba编程：

Private Sub Workbook_Open() Application.Caption = "传染病报告质量评价表 Desige By Vision http://cdcbl.9966.org" Dim TPath As String TPath = ActiveWorkbook.Path Application.ScreenUpdating = False Application.DisplayAlerts = False st = Dir(TPath & "\" & "Report.csv") If st = "" Then MsgBox "你尚未导出卡片！" & Chr(13) & "请从大疫情系统导出卡片，并存放到与本表同一文件夹。" & Chr(13) & "点确定退出！" ThisWorkbook.Close End If Workbooks.Open Filename:=TPath & "\" & "Report.csv" Cells.Select Selection.Copy Windows("自动质量评价.xls").Activate 'Application.DisplayAlerts = False Sheets("全部卡片").Select ' 将导出卡片(Report.csv)完整复制到“全部卡片页” Cells.Select ActiveSheet.Paste

Sheets("有效卡片").Select Cells.Select ActiveSheet.Paste Workbooks("Report.csv").Close Application.DisplayAlerts = True Sheets("有效卡片").Select

'剔除月内被删除的无效卡片

On Error Resume Next Dim id% For id = [AG65536].End(xlUp).Row To 1 Step -1 'AG 删除时间 If Month(Cells(id, 33)) = "." Then GoTo killit: If Month(Cells(id, 33)) = Month(Cells(id, 26)) Then Rows(id).Delete killit: Next id

'自动提取大疫情单位名称

Dim p& p = [有效卡片!AJ65536].End(xlUp).Row 'AJ 报告单位 Sheets("临时").Select Range("A").Select Selection.ClearContents Sheets("有效卡片").Select Sheets("有效卡片").Range("AJ1:AJ" & p).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("临时!C1"), Unique:=True Sheets("临时").Select Range("A1").Value = "序号" Range("B1").Value = "单位简称" Range("C1").Value = "提取信息" Range("D1").Value = "判断新增单位" Range("C2:C100").Select Range("A2:C100").Sort Key1:=Range("C2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ SortMethod:=xlPinYin, DataOption1:=xlSortNormal ActiveWindow.SmallScroll Down:=3 Application.CutCopyMode = False Range("A2").Select

'比较单位变化

Dim R As Long, temp As Long, Num As Long Const FHA As String = "×" Const FHB As String = "√" R = Range("C65536").End(xlUp).Row For temp = 2 To R With Application.WorksheetFunction If .CountIf(Sheets("单位").Columns("C:C"), VBA.Trim$(Cells(temp, 3).Value) & "*") = 0 Then Num = Sheets("单位").Range("C65536").End(xlUp).Row + 1 Cells(temp, 1).Value = FHA Cells(temp, 2).Value = FHA Rows(temp).Copy Destination:=Sheets("单位").Rows(Num) Application.CutCopyMode = False Cells(temp, 4).Value = FHB End If End With Next temp

Sheets("菜单").Select Range("A2").Select

'过滤卡片

Dim I%, arr(), rg As Range arr = Sheet2.Range("R1:AL" & Sheet2.[R65536].End(xlUp).Row) For I = 1 To UBound(arr) If arr(I, 15) = "审核状态" Or arr(I, 15) = "" Then GoSub doit: GoTo nxt If Not Sheet6.Columns("A:A").Find(What:=arr(I, 7), LookIn:=xlValues, LookAt:=xlWhole) Is Nothing Then GoSub doit nxt: Next I If Not rg Is Nothing Then rg.Delete Exit Sub doit: If rg Is Nothing Then Set rg = Sheet2.Rows(I) Else Set rg = Application.Union(rg, Sheet2.Rows(I)) End If

Return

Application.ScreenUpdating = True

End Sub

Private Sub CommandButton1_Click() '数据统计 Range("A4").Value = "1" If WorksheetFunction.CountIf(Sheet1.Range("A2:A100"), "×") > 0 Or WorksheetFunction.CountIf(Sheet1.Range("B2:B100"), "×") > 0 Then MsgBox "请转到“单位”页输入单位序号和单位简称，输入完毕后务必保存！！！" Sheet1.Select Sheet1.Range("A2").Select Else

Dim I%, J%, s$, arr1(), arr2(), arr3(), arr4(0 To 12), arr5()

arr1 = Sheet1.Range("A2:B" & Sheet1.Range("B65536").End(xlUp).Row) arr2 = Sheet1.Range("C2:C" & Sheet1.Range("B65536").End(xlUp).Row) arr3 = Sheet2.Range("R1:AJ" & Sheet2.Range("AJ65536").End(xlUp).Row) 'R 诊断时间 AJ 报告单位 arr5 = Sheet3.Range("A4B" & Sheet3.Range("B65536").End(xlUp).Row)

ReDim Preserve arr1(1 To UBound(arr1), 1 To 106) ReDim Preserve arr5(1 To UBound(arr5), 1 To 106)

'1序号 2单位 3报卡数量 4未及时报卡数 5未及时报告率 6未及时报告构成比 7报卡数量排名 8报卡及时性排名 9累计报卡时间 10平均报卡时间

For I = 1 To UBound(arr3) s = arr3(I, 19) For J = 1 To UBound(arr1) If arr2(J, 1) = s Then arr1(J, 3) = arr1(J, 3) + 1 arr1(J, 3 + Month(arr3(I, 9)) * 8) = arr1(J, 3 + Month(arr3(I, 9)) * 8) + 1 If arr3(I, 9) - arr3(I, 1) > 0 Then arr1(J, 9) = arr1(J, 9) + arr3(I, 9) - arr3(I, 1) arr1(J, 9 + Month(arr3(I, 9)) * 8) = arr1(J, 9 + Month(arr3(I, 9)) * 8) + arr3(I, 9) - arr3(I, 1) End If If arr3(I, 9) - arr3(I, 1) >= 2 Then arr1(J, 4) = arr1(J, 4) + 1 arr1(J, 4 + Month(arr3(I, 9)) * 8) = arr1(J, 4 + Month(arr3(I, 9)) * 8) + 1 arr4(0) = arr4(0) + 1 arr4(Month(arr3(I, 9))) = arr4(Month(arr3(I, 9))) + 1 End If Exit For End If Next J Next I

For I = 1 To UBound(arr1) For J = 0 To 12 If arr1(I, J * 8 + 3) = "" Then arr1(I, J * 8 + 3) = 0 arr1(I, J * 8 + 5) = 100 ElseIf arr1(I, J * 8 + 4) > 0 Then arr1(I, J * 8 + 5) = arr1(I, J * 8 + 4) / arr1(I, J * 8 + 3) * 100 arr1(I, J * 8 + 6) = arr1(I, J * 8 + 4) / arr4(J) * 100 Else arr1(I, J * 8 + 5) = 0 End If Next J Next I

Application.ScreenUpdating = False Sheet3.Select With Range("A4J" & [A65536].End(xlUp).Row + 100) .ClearContents .Borders.LineStyle = xlNone Range("A4B" & UBound(arr1) + 3).Borders.LineStyle = xlContinuous End With Range("A4B" & UBound(arr1) + 3) = arr1 For I = 4 To UBound(arr1) + 3 For J = 0 To 12 Cells(I, J * 8 + 7) = Application.Rank(Cells(I, J * 8 + 3), Range(Cells(4, J * 8 + 3), Cells(3 + UBound(arr1), J * 8 + 3))) Cells(I, J * 8 + 8) = Application.Rank(Cells(I, J * 8 + 5), Range(Cells(4, J * 8 + 5), Cells(3 + UBound(arr1), J * 8 + 5)), 1) If Cells(I, J * 8 + 3) <> 0 Then Cells(I, J * 8 + 10) = Cells(I, J * 8 + 9) / Cells(I, J * 8 + 3) If Cells(I, J * 8 + 3) = 0 Then Cells(I, J * 8 + 10) = 0 If Cells(I, J * 8 + 4) = "" Then Cells(I, J * 8 + 6) = 0 If Cells(I, J * 8 + 4) = "" Then Cells(I, J * 8 + 4) = 0 Next J Next I

End If

'Sheet3.Select 'Range("A3").Select

Application.ScreenUpdating = True

'qq = Sheet2.[AE65536].End(xlUp).Row 'MsgBox "共分析" & qq & "张有效卡片。", , "统计完毕！"

End Sub

Private Sub CommandButton2_Click() '绘制图表

Dim m%, n%, arr5(), arr6(), arr8(), arr9(), arr10(), arr11() arr5 = Sheet3.Range("A4B" & Sheet3.Range("B65536").End(xlUp).Row) arr6 = Sheet9.Range("R3:AD" & Sheet3.Range("B65536").End(xlUp).Row) arr8 = Sheet4.Range("R3:AD" & Sheet3.Range("B65536").End(xlUp).Row) arr9 = Sheet7.Range("R4:AD" & Sheet3.Range("B65536").End(xlUp).Row) arr10 = Sheet7.Range("AG4:AS" & Sheet3.Range("B65536").End(xlUp).Row) arr11 = Sheet8.Range("A3:O" & Sheet3.Range("B65536").End(xlUp).Row) ReDim Preserve arr5(1 To UBound(arr5), 1 To 106)

For m = 1 To UBound(arr5) For n = 1 To 13 arr6(m, n) = arr5(m, n * 8 - 2) arr8(m, n) = arr5(m, n * 8 + 2) arr9(m, n) = arr5(m, n * 8 - 5) arr10(m, n) = arr5(m, n * 8 - 4) arr11(m, n) = arr5(m, n * 8 - 5) Next n Next m

Application.ScreenUpdating = False

Sheet9.Select With Sheet9.Range("P3:AM" & [A65536].End(xlUp).Row + 100) .ClearContents .Borders.LineStyle = xlNone Sheet9.Range("P2:AD" & UBound(arr5) + 2).Borders.LineStyle = xlContinuous End With Sheet9.Range("M4:N" & UBound(arr5) + 3) = arr5 Sheet9.Range("P3" & UBound(arr5) + 2) = arr5 Sheet9.Range("R3:AD" & UBound(arr5) + 2) = arr6 For m = 3 To UBound(arr5) + 3 For n = 1 To 100 Next n Next m

Sheet4.Select With Sheet4.Range("P3:AL" & [A65536].End(xlUp).Row + 100) .ClearContents .Borders.LineStyle = xlNone Sheet4.Range("P2:AD" & UBound(arr5) + 2).Borders.LineStyle = xlContinuous End With Sheet4.Range("P3" & UBound(arr5) + 2) = arr5 Sheet4.Range("R3:AD" & UBound(arr5) + 2) = arr8 For m = 3 To UBound(arr5) + 3 For n = 1 To 100 Next n Next m

Sheet7.Select With Sheet7.Range("P4:BF" & [A65536].End(xlUp).Row + 100) .ClearContents .Borders.LineStyle = xlNone Sheet7.Range("P2:AS" & UBound(arr5) + 3).Borders.LineStyle = xlContinuous End With Sheet7.Range("P4" & UBound(arr5) + 3) = arr5 Sheet7.Range("AE4:AF" & UBound(arr5) + 3) = arr5 Sheet7.Range("R4:AD" & UBound(arr5) + 3) = arr9 Sheet7.Range("AG4:AS" & UBound(arr5) + 3) = arr10 For m = 3 To UBound(arr5) + 3 For n = 1 To 100 Next n Next m

Sheet8.Select With Sheet8.Range("A3:Z" & [A65536].End(xlUp).Row + 100) .ClearContents .Borders.LineStyle = xlNone Sheet8.Range("A2:O" & UBound(arr5) + 2).Borders.LineStyle = xlContinuous End With Sheet8.Range("A3:B" & UBound(arr5) + 2) = arr5 Sheet8.Range("C3:O" & UBound(arr5) + 2) = arr11 For m = 3 To UBound(arr5) + 3 For n = 1 To 100 Next n Next m

Sheet7.Select Sheet7.Range("C4").Select

Application.ScreenUpdating = True

End Sub

Private Sub CommandButton3_Click() Sheets("菜单").Select End Sub

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameteexsheet As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Private Sub CommandButton1_Click() Sheets("评价").Select End Sub

Private Sub CommandButton14_Click() Sheet2.Select Sheet2.Range("A1:AL65536").ClearContents Sheet11.Select Sheet11.Range("A1:AL65536").ClearContents Sheet10.Select ThisWorkbook.Save End Sub

Private Sub CommandButton15_Click() ShellExecute hwnd, "open", "http://cdcbl.9966.org/viewthread.php?tid=1297&extra=page%3D1", "", "", 1 End Sub

Private Sub CommandButton2_Click() Sheets("迟报条图").Select End Sub

Private Sub CommandButton3_Click() Sheets("迟报构成").Select End Sub

Private Sub CommandButton4_Click() Sheets("报卡及时性条图").Select End Sub

Private Sub CommandButton5_Click() Sheets("零报统计").Select End Sub

Private Sub CommandButton6_Click() Sheets("单位").Select End Sub

Private Sub CommandButton7_Click() Sheets("设置").Select End Sub

Private Sub CommandButton8_Click() Sheet12.Select Range("A3:G" & [G65536].End(xlUp).Row).ClearContents With Sheet2 Dim arr(1 To 500, 1 To 7) Dim I%, J% J = 1 For I = 1 To Sheet2.[A65536].End(xlUp).Row If Val(.Cells(I, 10)) < 15 And .Cells(I, 6) = "" Then arr(J, 1) = .Cells(I, 36) arr(J, 2) = .Cells(I, 5) arr(J, 3) = .Cells(I, 7) arr(J, 4) = .Cells(I, 10) arr(J, 5) = .Cells(I, 13) arr(J, 6) = .Cells(I, 18) arr(J, 7) = .Cells(I, 24) J = J + 1 End If Next Sheet12.Range("A3:G502") = arr

End With Sheets("家长姓名").Select Range("A3:G" & [G65536].End(xlUp).Row).Sort Key1:=Range("A3"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ SortMethod:=xlPinYin, DataOption1:=xlSortNormal

End Sub

Private Sub CommandButton9_Click() Sheets("qtjbwbz").Select End Sub

Private Sub CommandButton10_Click() Sheets("qtcrbwbz").Select End Sub

Private Sub CommandButton11_Click() Sheets("时段").Select End Sub

Private Sub CommandButton13_Click() Sheets("有效卡片").Select End Sub

Private Sub CommandButton12_Click() Sheets("全部卡片").Select End Sub

Private Sub CommandButton1_Click() Range("A2:C100").Select Range("A2:C100").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:= _ xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _ SortMethod:=xlPinYin, DataOption1:=xlSortNormal ActiveWindow.SmallScroll Down:=3 Application.CutCopyMode = False End Sub

Private Sub CommandButton2_Click() Sheets("菜单").Select ThisWorkbook.Save End Sub

Private Sub CommandButton3_Click()

Application.ScreenUpdating = False

Range("A2:C" & [C65536].End(xlUp).Row).Select '要另存为工作簿的选定区域 Selection.Copy Workbooks.Add Selection.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False ActiveSheet.Paste 'Range("A1").Select Application.CutCopyMode = False ActiveWorkbook.SaveAs Filename:=ThisWorkbook.Path & "\" & "单位备份.xls" ActiveWindow.Close ' MsgBox "单位名称已备份！" Application.ScreenUpdating = True Range("D1").Select End Sub