彎沉盆修正

作用：修正彎沉盆值，使其保持遞減趨勢。

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

存在的問題：上萬行數據時，運行速度很慢。