第二个宏
问题出现在
红字的地方
'第二个:
'1.选择一行
'2.新建页面,拷贝该行,设置新页面为当前页面
'3.该行取小数点最后一位
'4.按第一次的程序计算均值(3期~10期)和参考线
'5.同样算法,以定位线行(第10行)为第一行计算3期~10期,第一列加标题“第X期”
'6.第10行开始到第18行,画曲线图
Sub 新建页面()
Dim sheet01 As Worksheet
Dim sheetNew As Worksheet
Dim i As Integer
Dim j As Integer
Set sheet01 = ActiveWorkbook.ActiveSheet '对当前页面操作
Selection.Copy
'识别被选择区域
Dim selectedRange As Range
Dim origSelectedRange As Range
Set origSelectedRange = Application.Selection
'建立新页面并设置为当前页面
Set sheetNew = ActiveWorkbook.Sheets.Add
sheetNew.Activate
'被选行拷贝入新页面
sheetNew.Rows("1:1").Select
sheetNew.Paste
'侦测第一行数据列数
Dim n As Integer: n = 0
Do Until sheetNew.Cells(1, n + 1).Text = Empty
n = n + 1
Loop
'MsgBox n
'取小数点后最后一位
Dim data '暂存数据
Dim dataArr(): ReDim dataArr(n - 2) '取舍后的数据数组
For i = 2 To n
data = sheetNew.Cells(1, i).Value '获取数据
If Abs(data - CInt(data)) < 0.0000001 Then '是整数,取该整数
data = CInt(data)
ElseIf Abs(data * 10 - CInt(data * 10)) < 0.0000001 Then '小数点后只有一位
data = (FormatNumber(data, 1) - CInt(data - 0.5)) * 10
Else '小数点后有两位
data = (FormatNumber(data, 2) - FormatNumber(data - 0.05, 1)) * 100
End If
sheetNew.Cells(1, i) = CInt(data)
dataArr(i - 2) = CInt(data)
Next
'MsgBox dataArr(0) & "," & dataArr(1) & "," & dataArr(2)
'MsgBox UBound(dataArr)
'计算3~10期均值
Dim temp As Double
Dim stage As Integer
For stage = 2 To 9 '行:3~10期
sheetNew.Cells(stage, 1) = stage + 1 & "期均值"
For i = stage + 2 To n '列:
temp = 0
For j = 0 To stage
temp = temp + dataArr((i - 2) - j) / (stage + 1)
Next
sheetNew.Cells(stage, i).Value = FormatNumber(temp, 2)
Next
Next
'计算参考线
sheetNew.Cells(10, 1) = "定位线"
For i = 2 To n '列
temp = 0
For j = 2 To 9
temp = temp + sheetNew.Cells(j, i).Value / 8
Next
sheetNew.Cells(10, i).Value = FormatNumber(temp, 2)
Next
'取定位线小数点后最后一位
'For i = 2 To n
' data = sheetNew.Cells(10, i).Value '获取数据
' If Abs(data - CInt(data)) < 0.0000001 Then '是整数,取该整数
' data = CInt(data)
' ElseIf Abs(data * 10 - CInt(data * 10)) < 0.0000001 Then '小数点后只有一位
' data = (FormatNumber(data, 1) - CInt(data - 0.5)) * 10
' Else '小数点后有两位
' data = (FormatNumber(data, 2) - FormatNumber(data - 0.05, 1)) * 100
' End If
' sheetNew.Cells(10, i) = CInt(data)
' dataArr(i - 2) = CInt(data)
'Next
'根据定位线重新保存数组dataArr(不再取最后一位整数)
For i = 2 To n
dataArr(i - 2) = sheetNew.Cells(10, i).Value '获取数据
Next
'计算3~10期均值
For stage = 2 To 9 '行:11~18期
sheetNew.Cells(stage + 9, 1) = stage + 1 & "期均值"
For i = stage + 2 To n '列:
temp = 0
For j = 0 To stage
temp = temp + dataArr((i - 2) - j) / (stage + 1)
Next
sheetNew.Cells(stage + 9, i).Value = FormatNumber(temp, 2)
Next
Next
'10~18行画曲线
Range("10:18").Select
Charts.Add
ActiveChart.ChartType = xlLineMarkers
ActiveChart.SetSourceData Source:=sheetNew.Rows("SheetNew").Range("10:18"), PlotBy:= _
xlRows ActiveChart.Location Where:=xlLocationAsNewSheet
With ActiveChart
.HasTitle = False
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = False
End With
ActiveChart.PlotArea.Select
With Selection.Border
.ColorIndex = 16
.Weight = xlThin
.LineStyle = xlContinuous
End With
Selection.Fill.PresetTextured PresetTexture:=msoTextureOak
Selection.Fill.Visible = True
End Sub