返回列表 发帖

【EXCEL疫情报告质量评价表】2008.4.28

楼主你太有才了,狂顶

TOP

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

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

相关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

TOP

谢谢,我能看到了!接下来就准备仔细学习了,不懂时再向各位请教

TOP

支持。谢谢

TOP

好东西,希望看到更多

TOP

返回列表