Excel VBA質問箱 IV

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

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


7727 / 13644 ツリー ←次へ | 前へ→

【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 お礼[未読]

【37211】ある値がある行を削除
質問  KONKON  - 06/4/25(火) 19:28 -

引用なし
パスワード
   あるエクセルで1000行位あるデータのうちh列に”H17”という文字が
ある行を削除して上に詰めたいというマクロを作成したいのですが
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
  End With
Next Rw
Application.ScreenUpdating = True
End Sub

では消えません!何がいけませんか?

【37212】Re:ある値がある行を削除
発言  ぱっせんじゃー  - 06/4/25(火) 20:01 -

引用なし
パスワード
   下記のようにしてみてはいかがでしょう?

InStr(.Value, "H17*") > 0

If .Value Like "*H17*"

H列の値に"H17"が含まれていたら、という条件分岐
になります。
ですので、↓の場合も削除対象になります。

1H17
H17
H171

【37213】Re:ある値がある行を削除
発言  ponpon  - 06/4/25(火) 20:02 -

引用なし
パスワード
   ▼KONKON さん:
こんばんは。

>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 ’変更
    If InStr(.Value, "H17") > 0 Then .EntireRow.Delete

>  End With
>Next Rw
>Application.ScreenUpdating = True
>End Sub
>
でどうでしょう?
関数でを埋め込んでやる方法もありますね。

【37217】Re:ある値がある行を削除
回答  Kein  - 06/4/25(火) 20:55 -

引用なし
パスワード
   数式を埋めて判定し、行を削除するコードなら

Sub Del_Row()
  Application.ScreenUpdating = False
  On Error Resume Next
  With Range("H1", Range("H65536").End(xlUp)).Offset(, 26)
   .Formula = "=IF(ISERR(SEARCH(""H17*"",$H1)),"""",1)"
   .SpecialCells(3, 1).EntireRow.Delete xlShiftUp
   .ClearContents
  End With
  Application.ScreenUpdating = True
End Sub

てな感じです。

【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

【37226】Re:ある値がある行を削除
お礼  KONKON  - 06/4/26(水) 12:29 -

引用なし
パスワード
   Hirofumi さんをはじめ回答を頂いた方みなさんありがとうございました。
無事にできました。
またお世話になることがあると思いますが、よろしくお願いします。

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