Excel vba 重複削除、連番に並び替え

画像のようなExcelシートがありB列のナンバーの重複を削除したいです。その際にC列の日付が古いものを削除してほしいです。またそのナンバーを数字の小さい順に上から並べ替えたいです。並べ替えの際にその行すべて移動させてください。
またこの作業をする前に表の横に書いてあるVBAを使用して「NG」と「中断」の行は削除します。

できればこのVBAに続けて書きたかったのですがうまくいきませんでした。一つにまとめるとコードが長くなり複雑になりますか？2つに分けて作成したほうがいいのでしょうか？

それも踏まえて詳しいかた教えて下さい。説明ヘタですいません。

質問者からの補足コメント

• Sub DeleteRowsWithKeywords()
  Dim i As Long
  Dim ws As Worksheet Set ws = ThisWorkbook.Sheets("Sheet1") 'ワークシート名を適切に指定
  Application.ScreenUpdating = False
  For i = 100 To 1 Step -1
  f InStr(1, ws.Cells(i, 1).Value, "NG", vbTextCompare) > 0 Or InStr(1, ws.Cells(i, 1).Value, "中断",vbTextCompare) > 0 Then
  ws.Rows(i).Delete
  End If
  Next i
  Application.ScreenUpdating = True
  End Sub

    補足日時：2023/10/19 06:32

• 追加で聞きたいことがあります。
  表のなからランダムで3行選択して別シートに貼りつけたいです。※重複はしないようにおねがいします。

    補足日時：2023/10/20 00:09

No.6 回答者： tatsumaru77 回答日時： 2023/10/20 11:14

>表のなからランダムで3行選択して別シートに貼りつけたいです。

※重複はしないようにおねがいします。

以下のマクロを追加して、実行してください。（不要行削除と同じモジュールに登録します）
Sheet2にランダムな３行をコピーします。
もし、重複行削除と一緒に行いたいなら、
Public Sub 不要行削除()
の最後で、ランダム3行()をcallしてください。

Public Sub ランダム3行()
Dim maxrow As Long
Dim ws As Worksheet
Dim ws2 As Worksheet
Dim row1 As Long
Dim row2 As Long: row2 = 2
Dim rctr As Long: rctr = 0
Dim arrrow As Variant
Dim i As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'ワークシート名を適切に指定
Set ws2 = ThisWorkbook.Sheets("Sheet2") 'ワークシート名を適切に指定
maxrow = ws.Cells(rows.Count, "A").End(xlUp).Row
If maxrow < 5 Then
For row1 = 2 To maxrow
ws2.Cells(row2, 1).Resize(1, 5).Value = ws.Cells(row1, 1).Resize(1, 5).Value
row2 = row2 + 1
Next
Exit Sub
End If
arrrow = Array(0, 0, 0)
Randomize
For i = 0 To UBound(arrrow)
Do
row1 = Int(Rnd * (maxrow - 1)) + 2
If row1 > maxrow Then
MsgBox (row1)
End If
If CheckRow(row1, i, arrrow) = True Then Exit Do
Loop
arrrow(i) = row1
ws2.Cells(row2, 1).Resize(1, 5).Value = ws.Cells(row1, 1).Resize(1, 5).Value
row2 = row2 + 1
Next
End Sub
Private Function CheckRow(ByVal row1 As Long, ByVal cx As Long, ByRef arrrow As Variant)
CheckRow = False
Dim j As Long
For j = 0 To cx - 1
If row1 = arrrow(j) Then Exit Function
Next
CheckRow = True
End Function

No.5 回答者： tatsumaru77 回答日時： 2023/10/19 17:42

１．あなたが用意したマクロ「DeleteRowsWithKeywords」

が正しく動作することを確認してください。

２．以下のマクロを「DeleteRowsWithKeywords」と同じ
標準モジュールに登録してください。

Public Sub 不要行削除()
Dim maxrow As Long
Dim ws As Worksheet
Dim wrow As Long
Set ws = ThisWorkbook.Sheets("Sheet1") 'ワークシート名を適切に指定
'Call DeleteRowsWithKeywords
maxrow = ws.Cells(rows.Count, "A").End(xlUp).Row
ws.Range("A2:E" & maxrow).Sort key1:=Range("B2"), order1:=xlAscending, key2:=Range("C2"), order2:=xlDescending, Header:=xlNo
For wrow = maxrow To 3 Step -1
If ws.Cells(wrow, "B").Value = ws.Cells(wrow - 1, "B").Value Then
ws.rows(wrow).Delete
End If
Next
End Sub

３．上記のマクロ である不要行削除()は、
「NG」と「中断」の行が削除された状態であることを前提に動作します。

４．DeleteRowsWithKeywordsが正しく動作することが確認できましたら、
'Call DeleteRowsWithKeywords
の行のコメントを外してください。
そうすると、不要行削除()を実行するだけで、一度に、「NG」と「中断」の行削除と、重複行の削除が行われます。

この回答へのお礼

返信遅くなりました。うまくいきましたありがとうございます。

お礼日時：2023/10/19 23:50

No.4 回答者： tatsumaru77 回答日時： 2023/10/19 10:59

不明点です。

１．提示されたマクロ（DeleteRowsWithKeywords）は、実際に動かして、正しく動作した実績がありますでしょうか。実績があるなら、新しいマクロをつくり、最初にDeleteRowsWithKeywordsを呼び出します。
その後、No3で述べられたようにソートして、重複行を削除します。

２．ソート時、行全体を移動とのことですが、E列が最終列でしょうか。
（A列～E列の範囲をソート）

No.3 回答者： kamejiro 回答日時： 2023/10/19 05:28

#1です。

重複の削除する前に、並べ替えます。キー1がナンバー、キー2が日付（降順）なら、日付の古い方が下にきます。その後にナンバーのみで重複の削除です。ご提示されたVBAのソースですが、ボヤけていて読み取れません。自身がスマホだからかもしれませんが。

No.2 回答者： tatsumaru77 回答日時： 2023/10/18 23:20

表の横のVBAは、画像ではなく、テキストとして、提示していただけませんでしょうか。

マクロに組み込む場合でも、テキストになっていないと、組み込めません。

No.1 回答者： kamejiro 回答日時： 2023/10/18 22:57

こめんさい。

質問内容とは異なりますが。VBAを使わなくてもメニューから「データ→重複の削除」をうまく使ってできませんか。その操作をマクロの自動記録を使ってソースを取ることもできます。

この回答へのお礼

返信ありがとうございます。
重複の削除自体はできるとおもいますが、古い日付を削除するなど細かい設定もできるのでしょうか？

お礼日時：2023/10/18 23:08