重複する行を削除するマクロで質問です。

重複する行を削除するマクロで質問です。 3万行くらいからなるデータで、セルBの重複行を削除するマクロをネットから丸パクリしてつくったのですが Sub Test2() 'データの最終行を取得 Dim maxRow As Long maxRow = Cells(Rows.Count, 1).End(xlUp).Row '重複しているデータを削除 Range("A1:D" & maxRow).RemoveDuplicates (Array(2)) End Sub としたのですが、一つ問題があります。 扱うデータはとある実験データなのですが、数値がある限界に来るまでは上がり続け、限界を過ぎると下がり続けます。 例: 1 1 2 2 3 3 4 4 3 3 2 2 1 1 これを上のマクロで実行すると 1 2 3 4 となります。 私が求める結果は 1 2 3 4 3 2 1 です。 「上の行と比較して同じなら消す」という作業を最終行まで繰り返すマクロも作ったのですが桁が多いからなのか私の作り方が悪いのかエラーにはならないもののずっとカーソルがクルクルしてしまいます。 そこでまずMAXになる行を割り出し、そこより上と下でわけて上のマクロを走らせれば良いと思ったのですがどのように書けばよいのでしょうか?

Visual Basic | Excel46閲覧

ベストアンサー

0

数式を使用した方法が既回答にありますが、実際のデータは質問本文で例示したような(それぞれの値が2行ずつで構成されたデータ)なのでしょうか? 1 1 2 2 3 3 4 4 3 3 2 2 1 1 ーーーーーーーーーーーーーーーーーーーーー 上記のようなパターンでしたらいいのですが、それぞれの値が2行ずつとは限らない場合は数式を修正する必要があります。 添付図を確認してください。 E列を作業列として使用しています。 E1に 1 E2~最終行までに次式を入れて値に変換しました。 =IF(B1<>B2,1,2) 作業列に1を返す行(残す) 2を返す行(削除) 重複の削除を行うと、罫線などの書式設定が消える可能性があるので、 作業列を基準にデータ全体を昇順で並び替え後、作業列に2を返した行と作業列をクリアする手順を取りました。 Sub test01() Dim LR As Long Dim Cnt As Long '最終行を取得 LR = Cells(Rows.Count, 1).End(xlUp).Row 'E1セルに1を入れる Range("e1").Value = 1 'E2~最終行までに数式を入れる With Range("e2:e" & LR) .Formula = "=IF(B1<>B2,1,2)" '値に変換 .Value = .Value End With '削除対象行の件数を求める Cnt = WorksheetFunction.CountIf(Columns(5), 2) If Cnt Then '作業列を基準に表を並び替える(昇順) With Range("a1:e" & LR) .Sort key1:=Range("e1"), order1:=xlAscending, _ Header:=xlNo End With '作業列に2を返した行をクリア Range(Cells(LR - Cnt + 1, 1), Cells(LR, 4)).Clear End If '作業列をクリア Columns(5).Clear End Sub 添付図 (左)実行前 (右)実行後 ※(黄色で着色した範囲)以外は、実行時にクリアされます。 ※(図の着色は説明用です)

画像

ThanksImg質問者からのお礼コメント

皆様ありがとうございました。おかげで解決しました。

お礼日時:9/26 23:11

その他の回答(2件)

1

初級者なので遅かったら煽って下さい。 Sub try() Dim r As Range Dim i As Long i = WorksheetFunction.Max(Range("B:B")) Set r = Range("B:B").Find(i) Range("A1:D" & r.Row).RemoveDuplicates (Array(2)) Set r = Range("B:B").Find(i) Range("A" & r.Row, Cells(Rows.Count, "D").End(xlUp)).RemoveDuplicates (Array(2)) Range("A1", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeBlanks).EntireRow.Delete Set r = Nothing End Sub

1人がナイス!しています