|
如附件所示,点击按钮后可自动生产图表,再次点击则删除旧图表并生成新图表(生成图表的宏为录制的),我想把每次生成的图表自动调整其大小、位置=单元格P6:AD37,图表名称自动生成为单元格“F2”的内容再加上“抽查记录”的字样,可是每次生成的图表名称都会变成“图表n+1”,本菜实在无计可施,求论坛里的老师们帮帮忙,谢谢。
- Sub 随机抽样并排序()
- Application.ScreenUpdating = False
- Range("J11:K21").Value = Range("A11:B21").Value
- iRow = Range("J:L").Cells(11, 1).End(xlDown).Row
- Range("J:L").Cells(11, 1).Resize(iRow, 3).Clear '清除旧数据
- Dim shp As Object
- For Each shp In ActiveSheet.ChartObjects
- shp.Delete
- Next
- Dim dc As Object
- Set dc = CreateObject("Scripting.Dictionary")
- Randomize
- Dim i As Long, n As Integer, m As Long, s As Integer
- s = 1 'F、G列从第11行开始列数,如果从第一样这个数值应为-99
- For i = 11 To 45000 Step 100 '样本和抽样间隔,从A、B列第11行开始取数,如果从第一行这个数值应为1 TO 45000
- n = 0
- s = s + 10
- m = Int(Rnd * 99 + i)
- dc.Add m, ""
- Cells(s + n, "J") = Cells(m, "A")
- Cells(s + n, "K") = Cells(m, "B")
- Cells(s + n, "L") = Cells(m, "C")
- For n = 1 To 4 '抽样量为50
- Do While dc.exists(m)
- m = Int(Rnd * 99 + i)
- Loop
- dc.Add m, ""
- Cells(s + n, "J") = Cells(m, "A")
- Cells(s + n, "K") = Cells(m, "B")
- Cells(s + n, "L") = Cells(m, "C")
- Next
- Next
- Range("J10:L2300").Sort Key1:=Range("J10"), Order1:=xlAscending, Header:=xlGuess '升序,降序则把xlAscending替换成xlDescending
- With ActiveSheet.Shapes.AddChart
- With .Chart
- .ChartType = xlXYScatterLinesNoMarkers
- .SetSourceData Source:=Range("数据!$L$10:$L$510,数据!$D$10:$I$510")
- .SeriesCollection(1).XValues = "=数据!$J$10:$J$510"
- .SeriesCollection(2).XValues = "=数据!$J$10:$J$510"
- .SeriesCollection(3).XValues = "=数据!$J$10:$J$510"
- .SeriesCollection(4).XValues = "=数据!$J$10:$J$510"
- .SeriesCollection(5).XValues = "=数据!$J$10:$J$510"
- .SeriesCollection(6).XValues = "=数据!$J$10:$J$510"
- .SeriesCollection(6).ChartType = xlXYScatterLines
- .SetElement (msoElementChartTitleAboveChart)
- .ChartTitle.Text = Range("f2").Value & "抽查记录"
- End With
- .Name = Range("f2").Value & "抽查记录"
- .Top = Range("p6").Top
- .Left = Range("p6").Left
- .Width = Range("p6:ad37").Width
- .Height = Range("p6:ad37").Height
- End With
- Application.ScreenUpdating = True
- MsgBox "图表生成完成"
- End Sub
复制代码
|
|