首页 文章

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

提问于
浏览 次
0

我需要编写一个宏来读取GeoTechnical数据的工作表，根据特定行中的值选择数据，选择该行并继续读取直到工作表结束 . 选择所有行后，我需要将这些行复制到新的工作表中 . 我在大约10年内没有做过VBA，所以只是想回到原点 .

例如，我希望宏读取工作表，当列“I”在特定行上包含单词“Run”时，我想从该行中选择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
excel vba excel-vba

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（当循环退出时，选择相应的范围，如最后一行和“运行”中的那一行所定义） . 你在谈论空白单元格，但你的代码没有检查，我也不知道如果找到一个非空单元格（重新启动计数器？）该怎么办 . 请详细说明 .

    回复于
  • 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
    回复于
  • 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

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

    回复于

相关问题