マクロでの行削除処理について

質問

マクロで行削除をする際、
Rows("1:2").Delete Shift:=xlUp
Range("A1").EntireRow.Delete
上記どちらかで実施すると場所指定で削除できると思います。

例えばですが、
番号 科目
1 数学
2 数学
3 体育
4 体育
のようにデータがあるとして、番号の大きいほうの科目を
残すようにする方法で、変数を使ってやる方法はできないのでしょうか。
for文で行数まわすイメージを考えております。

回答No.2

imogasi · ベストアンサー

この手の問題は、処理ロジックが肝心で、それを検討したのかな。
＞or文で行数まわすイメージを考えております。
これは非常に危険をはらんでいる。
削除によって
データの繰り上がりや
最終行数の減少
があるから。
ーー
ことは一緒だが、下記はその点を意識せざるをえない書き方（コード）としてあるつもり。
Sub test01()
Worksheets("Sheet1").Range("A1:G100").Copy Worksheets("Sheet2").Range("A1")
With Worksheets("Sheet2")
.Range("A2:G100").Sort Key1:=.Range("B2"), Order1:=xlDescending, Key2:=.Range("A2") _
, Order2:=xlDescending
'---
d = .Range("a65536").End(xlUp).Row
MsgBox d
m = .Cells(2, "B") 'データ最初行は第２行からとする
i = 3 '処理は第３行目から
While Not .Cells(i, "B") = ""
If Cells(i, "B") = m Then
.Range("A" & i).EntireRow.Delete '行削除
'行削除で繰り上がってくるから行指定はそのまま
Else
m = .Cells(i, "B")
i = i + 1 '1行下をポイント
End If
Wend
End With
End Sub
というのを考えてみた。
ーーー
逆順ソートしているので気になるので下記でもやってみた。
データが科目＋番号順に昇順でソートしてあるものとして下記。
こちらは下行から上行に処理している。
Sub test02()
Worksheets("Sheet1").Range("A1:G100").Copy Worksheets("Sheet2").Range("A1")
With Worksheets("Sheet2")
d = .Range("a65536").End(xlUp).Row
MsgBox d
i = d - 1
While Not i = 1
If .Range("B" & i) = .Range("B" & i + 1) Then
.Range("A" & i).EntireRow.Delete '行削除
Else
i = i - 1 '1行上をポイント。直下行と違う場合で、残す
End If
Wend
End With
End Sub
ーーーー
少数例でしかテストしていないのでチェックよろしく。
コードの中での
Sheet1.Sheet2
"A2:G100”
A列、B列などは、勝手な設定なので本番では実情で改めること

お礼

回答ありがとうございます。
いつもこの手のパターンだとfor文などの回数文繰り返す処理を
考えてしまいます。
試しにやってみて結果を報告します。

回答No.3

onlyrom

既に回答は出てますが、、、

見出し行：　１行目
データ行：　２行目～
データ列：　Ａ～Ｃ列　（Ａ列：番号、Ｂ列：科目、Ｃ列：適当）

（１）質問のように、科目毎、番号毎に並んでいる場合
'------------------------------------------
Sub test333()
　Dim R As Long

　For R = Cells(Rows.Count, "A").End(xlUp).Row To 3 Step -1
　　　If Cells(R - 1, "B").Value = Cells(R, "B").Value Then
　　　　　Rows(R - 1).Delete xlShiftUp
　　　End If
　Next R

End Sub
'--------------------------------------------

（２）項目、番号が並んでない場合

先ず、第１キー：項目、第２キー：番号　で昇順にソートするコードを追加。
'--------------------------------------------
Sub Test555()

　Dim R As Long
　Dim LastRow As Long

　LastRow = Cells(Rows.Count, "A").End(xlUp).Row

　Range("A1:C" & LastRow).Sort _
　　　Key1:=Range("B2"), Order1:=xlAscending, _
　　　Key2:=Range("A2"), Order2:=xlAscending, _
　　　Header:=xlYes, OrderCustom:=1, MatchCase:=False, _
　　　Orientation:=xlTopToBottom, SortMethod:=xlPinYin

　For R = LastRow To 3 Step -1
　　　If Cells(R - 1, "B").Value = Cells(R, "B").Value Then
　　　　　Rows(R - 1).Delete xlShiftUp
　　　End If
　Next R

End Sub
'--------------------------------------------

以上。

お礼

回答ありがとうございます。
本を買って色々試しているのですが、
マクロに不慣れで難しく感じております。
基礎からやり直そうと思っておりますが、
結果は報告します。

回答No.1

lark_0925

新規ブックの標準モジュールに

'============================================================
Option Explicit
'======================================================================
Sub main()
　　Dim rr As Range
　　Call サンプル作成
　　MsgBox "これから処理します"
　　With Range("b2", Cells(Rows.Count, "b").End(xlUp))
　　　If .Row > 1 Then
　　　　With .Offset(0, 3)
　　　　　　.Formula = "=if(COUNTIF($B$2:B2,B2)<countif($b$2:$b$" _
　　　　　　　　　　　　& .Rows.Count + 1 & ",b2),1,"""")"
　　　　　　On Error Resume Next
　　　　　　Set rr = .SpecialCells(xlCellTypeFormulas, xlNumbers)
　　　　　　.Formula = ""
　　　　　　If Err.Number = 0 Then
　　　　　　　rr.EntireRow.Delete
　　　　　　　End If
　　　　　　End With
　　　　End If
　　　End With
End Sub
'======================================================================
Sub main2()
　　Dim rr As Range
　　Call サンプル作成
　　MsgBox "これから処理します"
　　With Range("b2", Cells(Rows.Count, "b").End(xlUp))
　　　If .Row > 1 Then
　　　　With .Offset(0, 3)
　　　　　　.Formula = "=if(and(row()<>" & .Rows.Count + 1 & ",b2=b3),1,"""")"
　　　　　　On Error Resume Next
　　　　　　Set rr = .SpecialCells(xlCellTypeFormulas, xlNumbers)
　　　　　　.Formula = ""
　　　　　　If Err.Number = 0 Then
　　　　　　　rr.EntireRow.Delete
　　　　　　　End If
　　　　　　End With
　　　　End If
　　　End With
End Sub
'======================================================================
Sub サンプル作成()
　　With ActiveSheet.Range("a1:b21")
　　　.Formula = Array("=row()-1", _
　　　　　　　　"=choose(int(rand()*5)+1,""国語""," & _
　　　　　　　　"""算数"",""理科"",""社会"",""英語"")")
　　　.Value = .Value
　　　.Range("a1:b1").Value = Array("番号", "科目")
　　　End With
End Sub

mainとmain2の二つを用意しました。
mainは、同一科目の番号が大きいものを残します。
main2は、連続している同一科目の番号が大きいものを残します。

試してみてください。

お礼

回答ありがとうございます。
本を購入したのですが、どうしても行を追加する可能性も
考えてやるようにしようって考えるといつもfor文でやってみよう
って思ってしまいます。
そうすると無限ループとかになってしまうのですが．．
試してみて結果を報告します。