|
代码粘贴如下：
Option Explicit
'工作表值改变事件用来调用数据汇总及绘图
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$B$2" Then
DrawChart Target
End If
End Sub '工作表选择事件用来产生数据有效性列表
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim RowCount As Long, FilterRange As Range, ValidRange As Range
Application.ScreenUpdating = False
If Target.Address = "$B$2" Then '检查是否B2格被选择了
'先检查明细表中是否有数据，有数据才进行操作
RowCount = Worksheets("明细表").Range("B65536").End(xlUp).Row
If RowCount < 2 Then
MsgBox "明细表中没有数据!" & vbCrLf & "请核实。"
Else
Columns("IV").Delete
Range("IV1") = "姓名"
Set FilterRange = Worksheets("明细表").Range("A1").Resize(RowCount, 24)
'调用高级筛选产生不重复姓名列表
FilterRange.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("IV1"), Unique:=True
'对姓名列排序
Columns("IV").Sort Key1:=Range("IV2"), Order1:=xlAscending, Header:=xlYes, _
Orientation:=xlTopToBottom, SortMethod:=xlPinYin
RowCount = Range("IV1").End(xlDown).Row
Set ValidRange = Range("IV2").Resize(RowCount - 1, 1)
'对B2格加上数据有效性序列
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=" & ValidRange.Address
End With
SendKeys "%{DOWN}"
End If
Else
Columns("IU:IV").Delete
End If
Set ValidRange = Nothing
Set FilterRange = Nothing
Application.ScreenUpdating = True
End Sub '汇总数据及绘制图表
Private Sub DrawChart(ByVal Rng As Range)
Dim RowCount As Long, FilterRange As Range, SortRange As Range
Dim TmpRng As Range, Cell As Range, ColRng As Range
Dim Ser As Series
Dim i As Integer
Dim WkFun As WorksheetFunction
Application.EnableEvents = False
On Error GoTo ErrorHandle
Set WkFun = Application.WorksheetFunction
Application.StatusBar = "正在运算，请等待........."
Application.ScreenUpdating = False
RowCount = Worksheets("明细表").Range("B65536").End(xlUp).Row
Set FilterRange = Worksheets("明细表").Range("A1").Resize(RowCount, 24)
Range("E3:I65536").Clear
Range("IU1:IU2").Delete xlShiftUp
Range("IU1") = "姓名"
Range("IU2") = Rng
'调用高级筛选将数据筛选到汇总表
FilterRange.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range("IU1:IU2"), _
CopyToRange:=Range("E2:I2")
'对筛选出的数据排序
Set SortRange = Range("E2").Resize(Range("E2").End(xlDown).Row - 1, 5)
SortRange.Sort Key1:=Range("E2"), Order1:=xlAscending, key2:=Range("F2"), order2:=xlAscending, _
Header:=xlYes, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
'处理排序后的数据
Set ColRng = Range("E3").Resize(Range("E2").End(xlDown).Row - 2, 1)
Set Cell = Range("E3")
Do Until IsEmpty(Cell)
RowCount = WkFun.CountIf(ColRng, Cell)
If RowCount = 1 Then
If WkFun.Count(Cell.Offset(0, 1).Resize(1, 4)) = 0 Then Cell.Resize(1, 5).Clear
Else
For i = 1 To 4
Set TmpRng = Cell.Offset(0, i).Resize(RowCount, 1)
If WkFun.Count(TmpRng) > 0 Then Cell.Offset(0, i) = WkFun.Average(TmpRng)
Next i
If WkFun.Count(Cell.Offset(0, 1).Resize(1, 4)) = 0 Then
Cell.Resize(RowCount, 5).Clear
Else
Cell.Offset(1, 0).Resize(RowCount - 1, 5).Clear
'设置同日期区域的第一行字体为红色
Cell.Resize(1, 5).Font.Color = RGB(255, 0, 0)
End If
End If
Set Cell = Cell.Offset(RowCount, 0)
Loop
'重新对整理后的数据排序
SortRange.Sort Key1:=Range("E2"), Order1:=xlAscending, Header:=xlYes, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
'设置数据区域的边框
SortRange.Borders.LineStyle = xlLineStyleNone
Set SortRange = Range("E2").CurrentRegion
With SortRange.Borders
.LineStyle = xlContinuous
.Weight = xlThin
End With
If SortRange.Rows.Count = 1 Then
MsgBox "无有效数据!"
GoTo ErrorHandle
Else
'更新图表数据
Set ColRng = SortRange.Offset(1, 0).Resize(SortRange.Rows.Count - 1, 1)
For i = 1 To 4
Set Cell = Range("E2").Offset(0, i)
Set Ser = ActiveSheet.ChartObjects(i).Chart.SeriesCollection(1)
With Ser
.XValues = ColRng
.Values = ColRng.Offset(0, i)
.Name = Cell
End With
Next i
End If
ErrorHandle:
Set Ser = Nothing
Set FilterRange = Nothing
Set SortRange = Nothing
Set TmpRng = Nothing
Set Cell = Nothing
Set ColRng = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub | 
楼主: jilianying
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2005-3-22 10:52
楼主