プロが教える店舗&オフィスのセキュリティ対策術

添付のようなエクセルがあります。
マクロを起動すると各購入品の一番新しい購入時間以外の行を消すようにしたいです。
※なお事前に購入品(名前順)と購入時間(新しい順)は並び替えております。

申し訳ありませんが、よろしくお願いします。

「VBA 条件付きの行の削除」の質問画像

A 回答 (5件)

No.4 お礼について



今回はソートしてますのでどちらでも対して変わりませんお好きな方をお使いください。
ソートしてはいけない場合は「Dictionary 機能」を使った方が圧倒的に早くなりますが、今回はソートする事によってまとめて行削除を行えているのでソートしてはいけないのならば今回の物より圧倒的に遅くなります。
    • good
    • 0

No.1 の改良版(一番時間がかかっているのが「Rows(行).Delete Shift:=xlUp」なので「Rows(行).ClearContents」しておいて後で一括削除しました。

6万行を5秒位で完了、元は2分強かかっていました。)

☆ Dictionary 機能を使わないバージョン
--------------------------------------------------------------------------------
Sub Sample()
Dim 行 As Long
Dim 範囲 As Range
Application.ScreenUpdating = False
Cells.Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlDescending, _
Header:=xlYes
For 行 = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Cells(行, 2).Value = Cells(行 - 1, 2).Value Then
Rows(行).ClearContents
End If
Next
Cells.Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlDescending, _
Header:=xlYes
Rows(Cells(Rows.Count, 2).End(xlUp).Row + 1 & ":" & Rows.Count).Delete Shift:=xlUp
ActiveSheet.UsedRange
Application.ScreenUpdating = True
End Sub
--------------------------------------------------------------------------------

☆ Dictionary 機能を使ったバージョン
--------------------------------------------------------------------------------
Sub Sample()
Dim 辞書 As Object
Dim 行 As Long
Dim 終 As Long
Cells.Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlDescending, _
Header:=xlYes
Set 辞書 = CreateObject("Scripting.Dictionary")
For 行 = 2 To Cells(Rows.Count, 2).End(xlUp).Row
If 辞書.Exists(Cells(行, 2).Text) Then
Rows(行).ClearContents
Else
辞書.Add Cells(行, 2).Text, 行
End If
Next
Set 辞書 = Nothing
Cells.Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlDescending, _
Header:=xlYes
Rows(Cells(Rows.Count, 2).End(xlUp).Row+1 & ":" & Rows.Count).Delete Shift:=xlUp
ActiveSheet.UsedRange
Application.ScreenUpdating = True
End Sub
--------------------------------------------------------------------------------
    • good
    • 0
この回答へのお礼

回答ありがとうございます。二つのバージョンがありますが、2つの違い(利点)はどういったものがありますでしょうか?

お礼日時:2017/12/04 07:07

No.2です。



前回の投稿で誤記がありました。

>B・C列の並びが別々でも・・・

>B・C列の並びがバラバラでも・・・
です。

すなわちマクロ実行前の並び替えは不要です。m(_ _)m
    • good
    • 0
この回答へのお礼

ありがとうございます。試してみます!

お礼日時:2017/12/04 07:05

こんばんは!



B・C列の並びが別々でも対応できるようにしてみました。
一例です。

Sub Sample1()
Dim myDic As Object
Dim myRng As Range, myR
Dim i As Long, lastRow As Long, myStr As String

Set myDic = CreateObject("Scripting.Dictionary")
lastRow = Cells(Rows.Count, "B").End(xlUp).Row
myR = Range(Cells(2, "B"), Cells(lastRow, "C"))
For i = 1 To UBound(myR, 1)
myStr = myR(i, 1)
If Not myDic.exists(myStr) Then
myDic.Add myStr, myR(i, 2)
Else
If myR(i, 2) > myDic(myStr) Then
myDic(myStr) = myR(i, 2)
End If
End If
Next i
For i = 2 To lastRow
myStr = Cells(i, "B")
If Cells(i, "C") <> myDic(myStr) Then
If myRng Is Nothing Then
Set myRng = Cells(i, "B")
Else
Set myRng = Union(myRng, Cells(i, "B"))
End If
End If
Next i
Set myDic = Nothing
If Not myRng Is Nothing Then '//←念のため//
myRng.EntireRow.Delete
End If
MsgBox "完了"
End Sub

こんな感じではどうでしょうか?m(_ _)m
    • good
    • 0

こんな感じはいかがでしょうか?


--------------------------------------------------------------------------------
Sub Sample()
Dim 行 As Long
Application.ScreenUpdating = False
Cells.Sort _
Key1:=Range("B2"), Order1:=xlAscending, _
Key2:=Range("C2"), Order2:=xlDescending, _
Header:=xlYes
For 行 = Cells(Rows.Count, 2).End(xlUp).Row To 2 Step -1
If Cells(行, 2).Value = Cells(行 - 1, 2).Value Then
Rows(行).Delete Shift:=xlUp
End If
Next
Application.ScreenUpdating = True
End Sub
--------------------------------------------------------------------------------
※ ソート部もあります不要ならば「Cells.Sort _」から「Header:=xlYes」を削除してください。
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!