程序员家园论坛软件开发Visual Basic编程技术 [求助]最最紧急求助!EXCEL里类型不匹配问题·~·

1  /  1  页   1 跳转 查看:643

[求助]最最紧急求助!EXCEL里类型不匹配问题·~·

[求助]最最紧急求助!EXCEL里类型不匹配问题·~·

出现在红字的地方

'第一个:
'1.选择n列
'2.计算每行数据小数点最后一位的最大值的和最小值之间的差
'3.差值小于5的不要(删除所选列内的数字,不是删除整行)
'4.差值大于5的把整行提前(空一行),并且在行末记录原行号
'说明:程序运行完后会提示“类型不匹配”,尚未找到原因
Sub 计算最大最小值差()
Dim sheet01 As Worksheet
Dim i As Integer
Dim j As Integer
Set sheet01 = ActiveWorkbook.ActiveSheet    '对当前页面操作
'识别被选择区域
Dim selectedRange As Range
Dim origSelectedRange As Range
Set origSelectedRange = Application.Selection
Dim nColumns As Long:  nColumns = origSelectedRange.Columns.Count  '识别被选区域列数
Dim nRows As Long:  nRows = origSelectedRange.Rows.Count  '识别被选区域行数
Dim row_1st As Long: row_1st = origSelectedRange.Cells.Row  '识别所选区域的第一行行号
Dim col_1st As Long: col_1st = origSelectedRange.Cells.Column  '识别所选区域的第一列列号
'侦测所选区域的数据行列数
Dim m As Integer: m = 0
Do Until sheet01.Cells(m + 1, col_1st).Text = Empty
    m = m + 1
Loop
Dim n As Integer: n = 0
Do Until sheet01.Cells(row_1st, n + 1).Text = Empty
    n = n + 1
Loop
'修正行数
If nRows > m Then nRows = m
'计算每行数据小数点最后一位(第2位)的最大值的和最小值之间的差
Dim temp  '暂存行数据
Dim keptRows: ReDim keptRows(0)  '保留的数据
Dim data As Double  '暂存数据
Dim max As Integer    '最大值
Dim min As Integer    '最小值
Dim delt(): ReDim delt(n)  '每行的最大最小差值
For i = row_1st To row_1st + nRows - 1 '每行
    max = 0
    min = 10
    For j = col_1st To col_1st + nColumns - 1
        data = sheet01.Cells(i, j).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
        If data > max Then max = CInt(data)
        If data < min Then min = CInt(data)
    Next
    '保持差值大于5的行数据
    If max - min >= 5 Then
        'sheet01.Cells(i, col_1st + nColumns) = "原第" & i & "行"
        ReDim temp(nColumns)
        For j = col_1st To col_1st + nColumns - 1
            temp(j - col_1st) = sheet01.Cells(i, j).Value
        Next
        temp(nColumns) = "原第" & i & "行"
        keptRows(UBound(keptRows)) = temp
        ReDim Preserve keptRows(UBound(keptRows) + 1)
    End If
Next
ReDim Preserve keptRows(UBound(keptRows) + 1)
'MsgBox UBound(keptRows)
'MsgBox keptRows(0)(4)
'删除旧数据
origSelectedRange.ClearContents
'填写新数据
For i = row_1st To row_1st + UBound(keptRows)
  For j = col_1st To col_1st + nColumns
        sheet01.Cells(i + (i - row_1st), j) = keptRows(i - row_1st)(j - col_1st)

    Next
Next
End Sub
 

回复:[求助]最最紧急求助!EXCEL里类型不匹配问题·~·

第二个宏
问题出现在红字的地方


'第二个:
'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
 

回复:[求助]最最紧急求助!EXCEL里类型不匹配问题·~·



高手帮帮我啊

拜谢了·~·~
 
1  /  1  页   1 跳转

版权所有 程序员家园论坛   Sitemap

Powered by Discuz!NT 2.1.202    Copyright © 2001-2008 Comsenz Inc.
Processed in 0.046875 second(s) , 3 queries. 浙ICP备07502118号
返顶部