Question

我在Vba中真的很新。我在excel中有一个很长的数据系列。但是我想选择并剪切一些特定的数据范围，这些数据范围在A列中，然后以“MIN”开始，直到33行。在每列中有60个数据系列具有不同的延长但是所有都从行填充“MIN”开始直到之后的33行。在我想要选择的范围之间，还有一些其他数据行不是我的目标。

我可以手工复制我的所有范围但需要时间。我有200个文件，每个文件有20000行，手工操作非常糟糕。我能找到的就是这段代码，我首先应该找到包含单元格填充“MIN”的行。然后我手工填写此代码中的范围。但它也需要时间。我想写一个代码： 1.找到所有填充“MIN”的单元格 2.选择具有“MIN”``的行 3.扩展选择直到33行
4.复制它找到的所有范围

提前谢谢。

此代码也有效但只提取具有单元格“min”的行并将其复制到另一个工作表中。但是我希望将选择从它找到的行（具有单元格“min”）延伸到之后的33行。

Public Sub FindAndCopyit()
Dim Rng As Range
Dim rCell As Range
Dim copyRng As Range
Dim LCell As Range
Dim WB As Workbook
Dim srcSH As Worksheet
Dim destSH As Worksheet
Dim sFirst As String
Dim CalcMode As Long
Const strSearch As String = "MIN"
Set WB = ActiveWorkbook
Set srcSH = WB.Sheets("Find")
Set destSH = WB.Sheets("final")
Set Rng = srcSH.Range("A1:G20000")
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With
Set rCell = Rng.Find(strSearch)
If Not rCell Is Nothing Then
Set copyRng = rCell.EntireRow
sFirst = rCell.Address
Do
Set rCell = Rng.FindNext(rCell)
If Not rCell Is Nothing And _
rCell.Address <> sFirst Then
Set copyRng = Union(rCell.EntireRow, copyRng)
End If
Loop Until rCell Is Nothing Or sFirst = rCell.Address
End If
Set LCell = destSH.Cells(Rows.Count, "A").End(xlUp)(2)
If Not copyRng Is Nothing Then
With copyRng
.Copy Destination:=LCell
.Delete
End With
End If
With Application
.CutCopyMode = False
.Calculation = CalcMode
.ScreenUpdating = True
End With

End Sub

你能帮我解决一下吗？

Answer 1

尝试更换：

Set copyRng = rCell.EntireRow

带

Set copyRng = Range(rCell, rCell(33, 1)).EntireRow

选择excel中的特定范围

1 个答案: