0

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

例如，我希望宏读取工作表，当“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
4

3 回答 3

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

  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

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

于 2013-09-19T20:59:43.603 回答
0 
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
于 2013-09-19T20:56:49.363 回答
0

我喜欢短代码：

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

        ActiveSheet.Range("$I$1:$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

现在您只需将其粘贴到新工作表中，也可以自动化...

于 2013-09-20T14:59:41.117 回答