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
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

「Run」という単語が見つかるまで、列 I2 から列 I まで反復処理を開始します。この時点で、25 に達するまでセルのカウントを開始します (ループが終了し、最後の行と「実行」の行で定義された対応する範囲が選択されたとき)。あなたは空白のセルについて話していますが、あなたのコードはそれをチェックしていません。これについて詳しく教えてください。

于 2013-09-19T20:59:43.603 に答える
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 に答える
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 に答える