vba Excel 宏，读取工作表，选择数据范围，复制选择

Excel Macro, read a worksheet, select range of data, copy selection

提问by M Mayer

I need to write a macro that reads a worksheet of GeoTechnical data, selects the data based off a value in a particular row, select that row and continue reading until the end of worksheet. Once all rows are selected, I then need to copy those rows into a new worksheet. I haven't done VBA in about 10 years, so just trying to get back into things.

我需要编写一个宏来读取 GeoTechnical 数据工作表，根据特定行中的值选择数据，选择该行并继续读取直到工作表结束。选择所有行后，我需要将这些行复制到新工作表中。我已经有大约 10 年没有学过 VBA，所以只是想重新开始。

For example, I want the macro to read the worksheet, when column "I" contains the word "Run" on a particular row, I want to then select from that row, A:AM. Continue reading through the worksheet until the end of it. The end of the document is tricky as there are up to 10-15 blank rows sometimes in between groups of data in the worksheet. If there is more then 25 blank rows, then the document would be at the end. Once everything is selected, I then need to copy the selection for pasting into a new worksheet. Here is the code I have thus far, but I'm unable to get a selection:

例如，我希望宏读取工作表，当“I”列在特定行上包含“运行”一词时，我想从该行 A:AM 中进行选择。继续通读工作表，直到它结束。文档的结尾很棘手，因为有时在工作表中的数据组之间有多达 10-15 个空白行。如果有超过 25 个空白行，则文档将位于末尾。选择所有内容后，我需要复制选择以粘贴到新工作表中。这是我迄今为止的代码，但我无法选择：

Option Explicit
Sub GeoTechDB()
      Dim x As String
      Dim BlankCount As Integer
      ' Select first line of data.
      Range("I2").Select
      ' Set search variable value and counter.
      x = "Run"
      BlankCount = 0
      ' Set Do loop to read cell value, increment or reset counter and stop loop at end    'document when there
      ' is more then 25 blank cells in column "I", copy final selection
      Do Until BlankCount > 25
         ' Check active cell for search value "Run".
         If ActiveCell.Value = x Then
            'select the range of data when "Run" is found
            ActiveCell.Range("A:AM").Select
            'set counter to 0
            BlankCount = 0
            'Step down 1 row from present location
            ActiveCell.Offset(1, 0).Select
         Else
            'Step down 1 row from present location
            ActiveCell.Offset(1, 0).Select
            'if cell is empty then increment the counter
            BlankCount = BlankCount + 1
         End If
      Loop
   End Sub

采纳答案by varocarbas

I see various things wrong with your code. If I understood properly what you want, this code should deliver it:

我发现你的代码有很多问题。如果我正确理解你想要什么，这段代码应该提供它：

          ' Set Do loop to read cell value, increment or reset counter and stop loop at end    'document when there
          ' is more then 25 blank cells in column "I", copy final selection

  Dim x As String
  Dim BlankCount As Integer
  Range("I2").Select
  x = "Run"
  BlankCount = 0
  Dim found As Boolean
  Dim curVal As String
  Dim rowCount As Long
  Dim completed As Boolean
  rowCount = 2  
  Dim allRanges(5000) As Range
  Dim rangesCount As Long

  rangesCount = -1          
  notFirst = False
  Do Until completed
     rowCount = rowCount + 1

     curVal = Range("I" & CStr(rowCount)).Value

     If curVal = x Then
         found = True
?        BlankCounter = 0
         rangesCount = rangesCount + 1
         Set allRanges(rangesCount) = Range("A" & CStr(rowCount) & ":AM" & CStr(rowCount))

     ElseIf (found) Then
        If (IsEmpty(Range("I" & CStr(rowCount)).Value)) Then BlankCount = BlankCount + 1
        If BlankCount > 25 Then Exit Do
     End If

     If (rowCount >= 5000) Then Exit Do 'In the safest-side condition to avoid an infinite loop in case of not of finding what is intended. You can delete this line
  Loop

  If (rangesCount > 0) Then
     Dim curRange As Variant
     Dim allTogether As Range
     Set allTogether = allRanges(0)
     For Each curRange In allRanges
           If (Not curRange Is Nothing) Then Set allTogether = Union(curRange, allTogether)
     Next curRange

     allTogether.Select
  End If

It starts iterating through column I from I2, until finding the word "Run". In this moment, it starts to count cells until reaching 25 (when the loop is exited and the corresponding range, as defined by the last row and the one at "Run", is selected). You are talking about blank cells but your code does not check that, also I am not sure what to do in case of finding a non-blank cell (restarting the counter?). Please, elaborate more on this.

它从 I2 开始遍历 I 列，直到找到单词“Run”。在这一刻，它开始计算单元格，直到达到 25（当退出循环并选择由最后一行和“运行”处定义的相应范围时）。您正在谈论空白单元格，但您的代码没有检查，我也不知道在找到非空白单元格（重新启动计数器？）的情况下该怎么做。请详细说明这一点。

回答by Tim Williams

Sub GeoTechDB()
Const COLS_TO_COPY As Long = 39
Dim x As String, c As Range, rngCopy As Range
Dim BlankCount As Integer

    Set c = Range("I2")

    x = "Run"
    BlankCount = 0

    Do Until BlankCount > 25

    If Len(c.Value) = 0 Then
        BlankCount = BlankCount + 1
    Else
        BlankCount = 0
        If c.Value = x Then
           If rngCopy Is Nothing Then
               Set rngCopy = c.EntireRow.Cells(1) _
                              .Resize(1, COLS_TO_COPY)
           Else
                Set rngCopy = Application.Union(rngCopy, _
                             c.EntireRow.Cells(1) _
                               .Resize(1, COLS_TO_COPY))
           End If
        End If
    End If
    Set c = c.Offset(1, 0)
    Loop

    If Not rngCopy Is Nothing Then rngCopy.Copy Sheet2.Range("A2")

End Sub

回答by Max

i like short codes:

我喜欢短代码：

Sub column_I_contains_run()
        If ActiveSheet.FilterMode Then Selection.Autofilter 'if an autofilter already exists this is removed

        ActiveSheet.Range("$I:$I$" & ActiveSheet.Cells(1048576, 9).End(xlUp).Row).Autofilter Field:=1, Criteria1:="*run*"

    Range("A1:AM" & ActiveSheet.Cells(1048576, 9).End(xlUp).Row).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
    Selection.Copy
End Sub

now you just have to paste it into a new sheet, what could be automated also...

现在你只需要将它粘贴到一个新的工作表中，什么也可以自动化......