弯沉盆修正

来源：互联网发布：如何在淘宝开店流程编辑：程序博客网时间：2024/04/30 07:05

作用：修正弯沉盆值，使其保持递减趋势。

Sub XiuZheng()'按公式修正Application.ScreenUpdating = FalseDim RowsCount As Long '总行数Dim n As Integer '点数RowsCount = ActiveSheet.UsedRange.Rows.CountFor i = 2 To RowsCountIf Cells(i, "AI").Value = 1 Then    n = WorksheetFunction.CountA(Range(Cells(i, "G"), Cells(i, "O")))    If Cells(i, 6 + n).Value > Cells(i, 5 + n).Value Then '最后一个大于倒数第二个        Cells(i, 6 + n).Value = Cells(i, 5 + n).Value - 0.1        Cells(i, 6 + n).Interior.ColorIndex = 3    End If        For j = n - 1 To 3 Step -1 '倒数第二个到第三个        If Cells(i, 6 + j).Value > Cells(i, 5 + j).Value Then '后面一个大于前面一个            Cells(i, 6 + j).Value = Cells(i, 7 + j).Value + 0.1            Cells(i, 6 + j).Interior.ColorIndex = 3        End If    Next j        If Cells(i, 6 + 2).Value > Cells(i, 6 + 1).Value Then '第二个大于第一个        Cells(i, 6 + 2).Value = Cells(i, 6 + 1).Value - 0.4        Cells(i, 6 + 2).Interior.ColorIndex = 3    End IfEnd If    Next iApplication.ScreenUpdating = TrueEnd Sub

Sub FuCha()'采用线性插值，复查Application.ScreenUpdating = FalseDim RowsCount As Long '总行数Dim n As Integer '点数RowsCount = ActiveSheet.UsedRange.Rows.CountFor i = 2 To RowsCount    If Cells(i, "AI").Value = 1 Then        n = WorksheetFunction.CountA(Range(Cells(i, "G"), Cells(i, "O")))        For j = 8 To n + 5            If Cells(i, j).Value < Cells(i, j + 1).Value Then                Cells(i, j).Value = (Cells(i, j - 1).Value + Cells(i, j + 1).Value) / 2                Cells(i, j).Interior.ColorIndex = 6            End If        Next j    End IfNext iApplication.ScreenUpdating = TrueEnd Sub

Sub MakeTheSame()'使相邻的值相近的单元格内数值一样Application.ScreenUpdating = FalseDim RowsCount As Long '总行数Dim n As Integer '点数Dim tmp As DoubleRowsCount = ActiveSheet.UsedRange.Rows.CountFor i = 2 To RowsCount    If Cells(i, "AI").Value = 1 Then        n = WorksheetFunction.CountA(Range(Cells(i, "G"), Cells(i, "O")))        For j = 8 To n + 5            If Abs(Cells(i, j).Value - Cells(i, j + 1).Value) < 0.01 Then                Cells(i, j).Value = Application.WorksheetFunction.Max(Cells(i, j).Value, Cells(i, j + 1).Value)                Cells(i, j + 1).Value = Application.WorksheetFunction.Max(Cells(i, j).Value, Cells(i, j + 1).Value)                Cells(i, j).Interior.ColorIndex = 6            End If        Next j    End IfNext iApplication.ScreenUpdating = TrueEnd Sub

存在的问题：上万行数据时，运行速度很慢。