VBA指定行削除

下記のVBAで
・a列の最終行までの重複しているその行全体を削除
・b列の最終行までの「NG」と「中断」がある行全体を削除
したいのですがうまくいきません。どこにどのようにしたらできるでしょうか？
a列のの重複だけ削除されていて他の行が残ったりします。
詳しい方教えて下さい。お願いします。
Sub 一覧()
Dim lastRow As Long
Dim sourceRange As Range
Dim destinationRange As Range
Dim firstUnderscorePos As Integer
Dim lastUnderscorePos As Integer
Dim valueBeforeUnderscore As String
Dim valueAfterUnderscore As String

' シート１で最終行を取得
lastRow = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).row

' シート１でA2から最終行までの範囲を選択
Set sourceRange = Sheets("Sheet1").Range("A2:A" & lastRow)

' シート２のA1セルから貼り付け
Set destinationRange = Sheets("Sheet2").Range("A1")

' 最初の"_"部分までをA列に、最後の"_"部分のあとをB列に貼り付け
For Each cell In sourceRange
valueBeforeUnderscore = ""
valueAfterUnderscore = ""

' "_"の位置を取得
firstUnderscorePos = InStr(1, cell.value, "_")
lastUnderscorePos = InStrRev(cell.value, "_")

' "_"が存在する場合
If firstUnderscorePos > 0 And lastUnderscorePos > 0 Then
' "_"の前の部分を取得
valueBeforeUnderscore = Mid(cell.value, 1, firstUnderscorePos - 1)
' "_"の後の部分を取得
valueAfterUnderscore = Mid(cell.value, lastUnderscorePos + 1)
End If

' ".xlsx"を削除
valueBeforeUnderscore = Replace(valueBeforeUnderscore, ".xlsx", "")
valueAfterUnderscore = Replace(valueAfterUnderscore, ".xlsx", "")

' A列に貼り付け
destinationRange.value = valueBeforeUnderscore
' B列に貼り付け
destinationRange.Offset(0, 1).value = valueAfterUnderscore

' 次の行に移動
Set destinationRange = destinationRange.Offset(1, 0)
Next cell
End Sub

No.2 回答者： tatsumaru77 回答日時： 2024/05/26 20:16

以下のマクロを登録してください。

Sub 一覧　実行後にこのマクロを実行してください。

Public Sub 行削除()
Dim ws As Worksheet
Dim lastRow As Long
Dim del_rows As Range
Dim dicT As Object
Dim ctr As Long: ctr = 0
Dim key As String
Dim dflag As Boolean
Dim rg As String
Dim wrow As Long
Set dicT = CreateObject("Scripting.Dictionary") ' 連想配列の定義

Set ws = Worksheets("Sheet2")
lastRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
For wrow = 1 To lastRow
dflag = False
If InStr(ws.Cells(wrow, 2).Value, "NG") > 0 Then dflag = True
If InStr(ws.Cells(wrow, 2).Value, "中断") > 0 Then dflag = True
If dflag = False Then
key = ws.Cells(wrow, 1).Value
If dicT.exists(key) = False Then
dicT(key) = True
Else
dflag = True
End If
End If
If dflag = True Then
rg = wrow & ":" & wrow
If ctr = 0 Then
Set del_rows = Range(rg)
Else
Set del_rows = Union(del_rows, Range(rg))
End If
ctr = ctr + 1
End If
Next
If ctr > 0 Then
del_rows.Delete
End If
MsgBox (ctr & "件削除完了")
End Sub

No.1 回答者： tatsumaru77 回答日時： 2024/05/26 17:06

削除したいのは、Sheet2のデータでしょうか？

Sheet1には、具体的には、どのような内容のデータがあるのでしょうか。

この回答へのお礼

削除したいのはSheet2のデータです。
Sheet１には0001_OKのような数字とOK、NGが一緒になった名前もものがA列に並んでいます。(0002_OK、0003_NG・・・）
Sheet2にSheet１の数字部分をA列にOK、NG部分をB列に分けて貼り付けています。Sheet2のA列で重複を探してその行を削除して、B列でNGを探してその行を削除したいです。

お礼日時：2024/05/26 18:40