找到J列为1的区域对应的最高点和最低点进行判断

renkangjizhen

Sub 找高低点()
Dim i%, arr(1 To 100, 1 To 2), brr(1 To 100, 1 To 2), m%, n%, x%, k%, d, y%, z%, crr(1 To 1000, 1 To 2),w%
Set d = CreateObject("scripting.dictionary")
If Cells(2, "h") < Cells(3, "h") Then
arr(1, 1) = Cells(2, "e"): arr(1, 2) = Cells(2, "f"): m = 1
Else
brr(1, 1) = Cells(2, "e"): brr(1, 2) = Cells(2, "f"): n = 1
End If
For i = 3 To [e65532].End(3).Row
d(Cells(i, "e").Value) = Cells(i, "f")
If Cells(i - 1, "h") < Cells(i, "h") And Cells(i + 1, "h") < Cells(i, "h") Then
n = n + 1: brr(n, 1) = Cells(i, "e"): brr(n, 2) = Cells(i, "f")
End If
If Cells(i - 1, "h") > Cells(i, "h") And Cells(i + 1, "h") > Cells(i, "h") Then
m = m + 1: arr(m, 1) = Cells(i, "e"): arr(m, 2) = Cells(i, "f")
End If
Next

For x = 1 To m
    If arr(x, 1) < brr(x, 1) Then
        For y = arr(x, 1) To brr(x, 1) Step 50
        k = k + 1: crr(k, 1) = y: crr(k, 2) = d(y)
        Next
        z = (arr(x + 1, 1) - brr(x, 1)) Mod 50
        For y = brr(x, 1) + z To arr(x + 1, 1) Step 50
        k = k + 1: crr(k, 1) = y: crr(k, 2) = d(y)
        Next
    End If

    If arr(x, 1) > brr(x, 1) Then
        z = (arr(x + 1, 1) - brr(x, 1)) Mod 50
        For y = brr(x, 1) + z To arr(x, 1) Step 50
        k = k + 1: crr(k, 1) = y: crr(k, 2) = d(y)
        Next
        For y = arr(x, 1) To brr(x + 1, 1) Step 50
        k = k + 1: crr(k, 1) = y: crr(k, 2) = d(y)
        Next
    End If
Next
[k2].Resize(k, 2) = crr
For w= 2 to ubound(crr)
If crr(w,1)-crr(w-1,1)<10 then
Range(cells(w,11),cells(w,12)).clearcontents
next
End Sub

renkangjizhen

看看是否符合你的要求

wwdfefgg

语法有点问题。。

wwdfefgg

renkangjizhen 发表于 2024-11-20 08:21
看看是否符合你的要求

麻烦看一下、、、、