呵呵，过奖，更希望各位高手一起完善程序。
动态图表部分表述过于繁琐，略过。
相关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
| 
发表于 2008-4-30 11:07
| 
