VBA处理相邻单元格的判断和数据处理

tvxqyanger

大神们！
    附件中的数据只是举例数据，实际数据可能有几千甚至上万行。所以请问有没有什么办法在考虑处理速度的前提下，进行处理。
    请不要怪我要求多，实在是本人有用过range和cells循环。不知道是我写的不对还是技术太菜，慢。所以前来请教大家。谢谢
    目的就是附件所讲：1.如果B列相邻单元格相减<0（B3减B2,B4减B3），则删除A2:B2或A2:B3的区域。
                                     2.提取B列与K数据最接近的值。以及对应的A列的时间。
                                     万分感谢。。。。

一把小刀闯天下

'自己设置一下单元格格式

Option Explicit

Sub test()
  Dim arr, i, j, m, min, p, brr, cnt, t
  arr = [a1].CurrentRegion.Offset(1)
  brr = arr: m = 1
  brr(m, 1) = arr(UBound(arr, 1) - 1, 1)
  brr(m, 2) = arr(UBound(arr, 1) - 1, 2)
  min = arr(UBound(arr, 1) - 1, 2)
  For i = UBound(arr, 1) - 2 To 1 Step -1
    If min - arr(i, 2) > 0 Then
      m = m + 1: min = arr(i, 2)
      brr(m, 1) = arr(i, 1): brr(m, 2) = arr(i, 2)
    Else
      For j = i To 1 Step -1
        If min - arr(j, 2) > 0 Then i = j + 1: Exit For
      Next
    End If
  Next
  If m = 0 Then MsgBox "!": Exit Sub
  For i = 1 To m / 2
    t = brr(i, 1): brr(i, 1) = brr(m - i + 1, 1): brr(m - i + 1, 1) = t
    t = brr(i, 2): brr(i, 2) = brr(m - i + 1, 2): brr(m - i + 1, 2) = t
  Next
  arr = Range("k2:n" & Cells(Rows.Count, "k").End(xlUp).Row)
  p = 1
  For i = 1 To UBound(arr, 1)
    For j = p To m
      If arr(i, 1) <= brr(j, 2) Then
        If arr(i, 1) = brr(j, 2) Then
          arr(i, 2) = brr(j, 2): arr(i, 3) = brr(j, 1)
        Else
          arr(i, 2) = brr(j - 1, 2): arr(i, 3) = brr(j - 1, 1)
        End If
        p = j: cnt = cnt + 1: Exit For
      End If
  Next j, i
  If cnt = 0 Then MsgBox "!!": Exit Sub
  arr(1, 4) = vbNullString
  For i = 2 To cnt
    arr(i, 4) = (arr(i, 2) - arr(i - 1, 2)) / (arr(i, 3) - arr(i - 1, 3)) / 24 / 60
  Next
  [d2].Resize(m, 2) = brr
  [k2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

tvxqyanger

一把小刀闯天下 发表于 2018-10-11 07:32
'自己设置一下单元格格式

Option Explicit

请问可以解释一下么？

tvxqyanger

一把小刀闯天下 发表于 2018-10-11 07:32
'自己设置一下单元格格式

Option Explicit

你好 。我试了一下，请问B列的条件成立后可以直接把满足条件部分在原始的A:B中删除么？因为实际我后面还有很多列数据，都是参考B列的判断原则进行删除的。

一把小刀闯天下

tvxqyanger 发表于 2018-10-11 11:20
你好 。我试了一下，请问B列的条件成立后可以直接把满足条件部分在原始的A:B中删除么？因为实际我后面还 ...

解释就免了，都是流水代码，无从下口
===============


把这行 [d2].Resize(m, 2) = brr 改成：
---------------
With [a2]
  .Resize(UBound(brr, 1) - 1, 2).ClearContents
  .Resize(m, 2) = brr
End With

tvxqyanger

一把小刀闯天下 发表于 2018-10-11 15:18
解释就免了，都是流水代码，无从下口
===============

还是感谢。下午已经自己瞎搞。解决了，谢谢

一把小刀闯天下

tvxqyanger 发表于 2018-10-11 19:08
还是感谢。下午已经自己瞎搞。解决了，谢谢

瞎搞都能解决问题，很不错的祝贺一下，哈哈哈

tvxqyanger

一把小刀闯天下 发表于 2018-10-11 19:31
瞎搞都能解决问题，很不错的祝贺一下，哈哈哈

主要还是您的思路。也就是用调试然后然后做了些修改。感谢！