弯沉盆修正

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

Sub XiuZheng()'按公式修正
Application.ScreenUpdating = False

Dim RowsCount As Long '总行数
Dim n As Integer '点数
RowsCount = ActiveSheet.UsedRange.Rows.Count

For i = 2 To RowsCount
If 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 If
End If    
Next i
Application.ScreenUpdating = True
End Sub

Sub FuCha()'采用线性插值，复查
Application.ScreenUpdating = False

Dim RowsCount As Long '总行数
Dim n As Integer '点数
RowsCount = ActiveSheet.UsedRange.Rows.Count

For 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 If
Next i
Application.ScreenUpdating = True
End Sub

Sub MakeTheSame()'使相邻的值相近的单元格内数值一样
Application.ScreenUpdating = False

Dim RowsCount As Long '总行数
Dim n As Integer '点数
Dim tmp As Double
RowsCount = ActiveSheet.UsedRange.Rows.Count

For 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 If
Next i
Application.ScreenUpdating = True
End Sub

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