此算法是从一列数据中去掉最大数值和最小数值,求出总和,平均值,计算出
 在cell中填充去掉的最大值,最小值, 总和,平均值和方差.
  算法效率有点低,主要解决业务问题了.

Public Sub aver()
    Application.ScreenUpdating = False
    Dim maxCount
    maxCount = 10  //最大行数
   For k = 0 To 12   //最大的列数
        Dim largeIndex
        Dim smallIndex
        Dim largerValue
        Dim smalValue
        Dim index
        Dim tAvgValue
        Dim varianceValue As Double
        index = 0
        'Largervalue And SmallValue
        For Each x In Range(Cells(1, k + 1), Cells(maxCount, k + 1))
                If index = 0 Then
                    largerValue = x
                    smallValue = x
                    largerIndex = index
                    smallIndex = index
                End If
                If x > largerValue Then
                        largerValue = x
                        largerIndex = index
                End If
                If x < smallValue Then
                        smallValue = x
                        smallIndex = index
                End If
                ‘Debug.Print "largerValue: " & largerValue & "  x:" & x
                index = index + 1
        Next x
        
        'Sum Value
        Dim sum
        sum = 0
        Dim arr(0 To 7)  //10个数的话,去掉最大,最小就是8的数组
        Dim i
        i = 0
        Dim curIndex
        curIndex = 0
        For Each x In Range(Cells(1, k + 1), Cells(maxCount, k + 1))
          If curIndex = largerIndex Then
          ElseIf curIndex = smallIndex Then
          Else
                sum = sum + x
                arr(i) = x
                i = i + 1
          End If
          
          curIndex = curIndex + 1
        Next x
        tAvgValue = sum / (maxCount - 2)
        
        Dim sum1 As Double
        sum1 = 0
        Dim temp
        For Each y In arr
            If Abs(y) > Abs(tAvgValue) Then
                    temp = Abs(y) - Abs(tAvgValue)
                    sum1 = sum1 + temp * temp
            Else
                    temp = Abs(tAvgValue) - Abs(y)
                    sum1 = sum1 + temp * temp
            End If
        Next y
        varianceValue = Sqr(sum1 / (maxCount - 2))
   'MsgBox " largerValue: " & largerValue & "smallValue:" & smallValue & " the sum is :" & sum & " the Avg is :" & sum / 8
  
   Worksheets("Sheet1").Cells(maxCount + 5, k + 1) = "LargerValue: " & largerValue
   Worksheets("Sheet1").Cells(maxCount + 6, k + 1) = "smallValue: " & smallValue
   Worksheets("Sheet1").Cells(maxCount + 7, k + 1) = "sum: " & sum
   Worksheets("Sheet1").Cells(maxCount + 8, k + 1) = "Avg: " & tAvgValue
   Worksheets("Sheet1").Cells(maxCount + 9, k + 1) = varianceValue
   
   Next k
   Application.ScreenUpdating = True
End Sub

本文演示利用Excel VBA编程实现多期栅格数据，逐像元计算物候参数：生长季始期（SOS）、生长季末期（EOS）和生长季长度（LOS），计算过程速度快！


说明：

（1）利用Raster to Point工具将栅格数据转换为点图层，结果为38998个点，由于每年有24个数据（半月合成），所以得到的一年的数据为一个38998行、24列的矩阵；

（2）动态阈值的实现方法是逐像元计算，（d2-d1）/d1，物候始期求最大值（正），物候末期求最小值（负）；

（3）sheet里保存38998*24的原始数据，sheet2为比率数据，sheet4为动态阈值及对应的影像期数。

代码如下：

Sub 逐像元阈值()
    Dim i As Integer
    Dim max As Double
    Dim min As Double
    Dim j As Long
    For j = 1 To 38998
        For i = 1 To 24
            If Sheet1.Cells(j, i).Value = 0 Then
                Sheet1.Cells(j, i).Value = Sheet1.Cells(j, i).Value + 0.000001
            End If
            If Sheet1.Cells(j, i).Value > 1 Then
                Sheet1.Cells(j, i).Value = 0.8
            End If
            If Sheet1.Cells(j, i).Value < 0 Then
                Sheet1.Cells(j, i).Value = 0.0000001
            End If
        Next i
    Next j
    max = 0
    min = 0
    For j = 1 To 38998
1:
        For i = 1 To 23
            If Sheet1.Cells(j, 1).Value = "" Then
                j = j + 1
                GoTo 1
            End If
            Sheet2.Cells(j, i).Value = (Sheet1.Cells(j, i + 1).Value - Sheet1.Cells(j, i).Value) / Sheet1.Cells(j, i).Value
        Next i
        
        For i = 1 To 17
            max = Application.WorksheetFunction.max(max, Sheet2.Cells(j, i).Value)
            If Sheet2.Cells(j, i).Value = max Then
                Sheet4.Cells(j, 1).Value = Sheet1.Cells(j, i + 1).Value
                Sheet4.Cells(j, 2).Value = i
            End If
        Next i
        max = 0
        
        For i = 16 To 23
            min = Application.WorksheetFunction.min(min, Sheet2.Cells(j, i).Value)
            If Sheet2.Cells(j, i).Value = min Then
                Sheet4.Cells(j, 4).Value = Sheet1.Cells(j, i).Value
                Sheet4.Cells(j, 5).Value = i
            End If
        Next i
        min = 0
    Next j
    MsgBox "Done !"
End Sub


计算结果：





刘一哥GIS：专注GIS教育，探索GIS奥秘，分享GIS价值！