Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


44533 / 76735 ←次へ | 前へ→

【37218】Re:ある値がある行を削除
回答  Hirofumi  - 06/4/25(火) 21:19 -

引用なし
パスワード
   H17が先頭にある場合と言う条件なら
Option Explicit

Public Sub Test()

  Dim Rw As Long
  
  Application.ScreenUpdating = False
  
  For Rw = Range("H65536").End(xlUp).Row To 1 Step -1
    With Range("H" & Rw)
'      If InStr(.Value, "H17*") > 0 Then .EntireRow.Delete
      '先頭にH17が有る場合に削除
      If InStr(1, .Value, "H17", vbBinaryCompare) = 1 Then
        .EntireRow.Delete
      End If
      '文字列中の何処かにH17が有る場合に削除
'      If InStr(1, .Value, "H17", vbBinaryCompare) > 0 Then
'        .EntireRow.Delete
'      End If
    End With
  Next Rw
  
  Application.ScreenUpdating = True
  
End Sub

ただ、削除の速度を上げる為、以下の様な事もします

Public Sub Sample()

  'データ列数(例えば基準位置A列〜I列までデータが有る場合)
  Const clngColumns As Long = 9
  '処理対象列位置(例えばH列、A列からの列Offset)
  Const clngCompare As Long = 7
  
  Dim i As Long
  Dim lngRows As Long
  Dim rngList As Range
  Dim vntData As Variant
  Dim lngDelete() As Long
  Dim lngCount As Long
  Dim strProm As String
  
  'Listの左上隅セル位置を基準として設定
  Set rngList = ActiveSheet.Cells(1, "A")
  With rngList
    'データ行数を取得
    lngRows = .Offset(65536 - .Row, _
              clngCompare).End(xlUp).Row - .Row + 1
    'データが無い場合
    If lngRows <= 1 Then
      strProm = "データが有りません"
      GoTo Wayout
    End If
    'データを配列に取得
    vntData = .Offset(, clngCompare).Resize(lngRows + 1).Value
    '削除Flag用の配列を確保
    ReDim lngDelete(1 To lngRows, 1 To 1)
  End With
  
  'H17の時に削除Flagを入れる
  For i = 1 To lngRows
    '先頭にH17が有る場合に削除
    If InStr(1, vntData(i, 1), "H17", vbBinaryCompare) = 1 Then
      lngDelete(i, 1) = 1
      lngCount = lngCount + 1
    End If
  Next i
  
  '画面更新を停止
'  Application.ScreenUpdating = False
  
  With rngList
    '削除Flagを出力
    .Offset(, clngColumns).Resize(lngRows).Value = lngDelete
    '削除FlagをKeyに整列
    .Resize(lngRows, clngColumns + 1).Sort _
        Key1:=.Offset(, clngColumns), Order1:=xlAscending, _
        Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
        Orientation:=xlTopToBottom, SortMethod:=xlStroke
    If lngCount > 0 Then
      'Flag行の削除
      .Offset(lngRows - lngCount).Resize(lngCount).EntireRow.Delete
    End If
    '削除Flagを削除
    .Offset(, clngColumns).EntireColumn.Delete
  End With
  
  strProm = "処理が完了しました"
  
Wayout:
  
  '画面更新を再開
  Application.ScreenUpdating = True
  
  Set rngList = Nothing
  
  MsgBox strProm, vbInformation
  
End Sub

0 hits

【37211】ある値がある行を削除 KONKON 06/4/25(火) 19:28 質問
【37212】Re:ある値がある行を削除 ぱっせんじゃー 06/4/25(火) 20:01 発言
【37213】Re:ある値がある行を削除 ponpon 06/4/25(火) 20:02 発言
【37217】Re:ある値がある行を削除 Kein 06/4/25(火) 20:55 回答
【37218】Re:ある値がある行を削除 Hirofumi 06/4/25(火) 21:19 回答
【37226】Re:ある値がある行を削除 KONKON 06/4/26(水) 12:29 お礼

44533 / 76735 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free