求批量保留中间的行，删除保留数据前后的行vba

420045140

气候数据，站点（是五位数字）数量和每月天数的不固定，所以并不能固定的删除前多少行和后多少行来截取我需要的站点数据。
我的想法是搜索站点的五位数字，删除这个数字之前的所有行，搜索另一个站点的数字，删除之后的行。
或者是搜索到一个站点之后，往后保留多少行，其余的都删除。（因为我所要保留的站点数据是连续的）

附件如下：
我想要保留的是    51053-52203   之间2015行数据。
文件有我想要的结果。其他均为原气候数据。
感谢帮助。

一把小刀闯天下

'怪事，2010版出错2016版就能用，搞不懂,晕死。

Option Explicit

Const FIRST As Long = 51053, LAST As Long = 52203   '开始、结束

Sub test()
  Dim filename(), i, j, k, kk, n, arr
  If Not getfilename(filename, ThisWorkbook.Path, ".xls") Then MsgBox "!": Exit Sub
  For i = 1 To UBound(filename)
    With GetObject(filename(i))
      arr = ActiveSheet.UsedRange
      If i = 1 Then ReDim brr(1 To Rows.Count, 1 To UBound(arr, 2))
      For j = 1 To UBound(arr, 1)
        If arr(j, 1) >= FIRST And arr(j, 1) <= LAST Then
          n = n + 1
          For k = 1 To UBound(arr, 2): brr(n, k) = arr(j, k): Next
        End If
      Next
      .Close
    End With
  Next
  With [o1]
    .Resize(Rows.Count - 1, UBound(brr, 2)).ClearContents
    If n > 0 Then .Resize(n, UBound(brr, 2)) = brr
  End With
End Sub

Function getfilename(filename, pth, mark) As Boolean
  Dim f, n
  If Right(pth, 1) <> "\" Then pth = pth & "\"
  f = Dir(pth & "*.*")
  Do While Len(f) > 0
    If LCase(Right(f, Len(mark))) = LCase(mark) Then
      n = n + 1: ReDim Preserve filename(1 To n)
      filename(n) = pth & f
    End If
    f = Dir
  Loop
  If n > 0 Then getfilename = True
End Function

liucf

只有一个文件是2015行

420045140

liucf 发表于 2018-6-9 21:34
只有一个文件是2015行

不好意思，貌似代码没有在里边。

420045140

liucf 发表于 2018-6-9 21:34
只有一个文件是2015行

不好意思，貌似代 码不在里边。

liucf

420045140 发表于 2018-6-9 23:16
不好意思，貌似代 码不在里边。

代码在里面,只是按钮指定宏与我的加载宏重名,直接进VBE里面运行就行

420045140

liucf 发表于 2018-6-10 09:25
代码在里面,只是按钮指定宏与我的加载宏重名,直接进VBE里面运行就行

谢谢您。 我试过了，可以用了

420045140

一把小刀闯天下 发表于 2018-6-9 21:33
'怪事，2010版出错2016版就能用，搞不懂,晕死。

Option Explicit

谢谢您。我正好是2016的。

420045140

liucf 发表于 2018-6-10 09:25
代码在里面,只是按钮指定宏与我的加载宏重名,直接进VBE里面运行就行

现在我想修改一下  查找的范围，我把代码复制到自己建的模块之后运行，Excel 提示对象变量或WITH变量未设置。就是下边的红色行，我猜测蓝色行也会出现这种情况，要怎么修改一下呢？

Sub DF0()
  Application.ScreenUpdating = False
  P = ActiveWorkbook.Path & "/"
  For Each File In CreateObject("Scripting.FilesyStemObject").GetFolder(P).Files
    If File.Name <> ThisWorkbook.Name And Left(File.Name, 1) <> "~" And LCase(File.Name) Like "*.xls*" Then
      Set W = Workbooks.Open(P & File.Name)
      Set S = W.Sheets(1)
      Set R = S.[A:A].Find(52267, , , 1)
      J = R.Row
      S.Rows(J & ":30000").EntireRow.Delete
      Set R = S.[A:A].Find(51053, , , 1)
      J = R.Row - 1
      S.Rows("1:" & J).EntireRow.Delete
      W.Save
      W.Close False
    End If
  Next
  Application.ScreenUpdating = True

End Sub

420045140

一把小刀闯天下 发表于 2018-6-9 21:33
'怪事，2010版出错2016版就能用，搞不懂,晕死。

Option Explicit

我试了试 ，我的2016也没反应