自动添加XY散点图，动态数据标签

yipzx

1. Attribute VB_Name = "模块1"
   
2. Sub myAddxyChartSeries()
   
3. Dim aChart, nS, i As Long, stR As String, iChartIndex As Integer
   
4. Dim sRng As Range, xRng As Range, yRng As Range, lRng As Range
   
5. 
   
6.     stR = "Please select a Chart:" & vbLf
   
7.     With ActiveSheet.ChartObjects
   
8.         If .Count = 0 Then
   
9.             MsgBox "ActiveSheet.ChartObjects.Count=0"
   
10.             Exit Sub
    
11.         End If
    
12.         For i = 1 To .Count
    
13.             stR = stR & vbLf & i & " - " & .Item(i).Name
    
14.         Next i
    
15.         Do Until iChartIndex > 0 And iChartIndex <= .Count
    
16.             iChartIndex = Application.InputBox(Prompt:=stR, Default:=1, Type:=1)
    
17.         Loop
    
18.         Set aChart = .Item(iChartIndex).Chart
    
19.     End With
    
20.    
    
21.     Do
    
22.         Set sRng = Application.InputBox(Prompt:="xyChart:", Type:=8)
    
23.     Loop Until sRng.Areas.Count = 1 And sRng.Rows.Count > 1 And sRng.Columns.Count = 3
    
24.    
    
25.     Set lRng = sRng.Offset(1, 0).Resize(sRng.Rows.Count - 1, 1)
    
26.     Set xRng = sRng.Offset(1, 1).Resize(sRng.Rows.Count - 1, 1)
    
27.     Set yRng = sRng.Offset(1, 2).Resize(sRng.Rows.Count - 1, 1)
    
28.    
    
29.     Set nS = aChart.SeriesCollection.NewSeries
    
30.     nS.Name = "='" & sRng.Worksheet.Name & "'!" & sRng.Resize(1, 1).Address
    
31.     nS.ChartType = xlXYScatter
    
32.     nS.XValues = xRng
    
33.     nS.Values = yRng
    
34.     For i = 1 To nS.Points.Count
    
35.         nS.Points(i).HasDataLabel = True
    
36.         nS.Points(i).DataLabel.text = "='" & sRng.Worksheet.Name & "'!" & lRng.Offset(i - 1, 0).Resize(1, 1).Address
    
37.     Next i
    
38.    
    
39. End Sub
    

复制代码