エクセルに関して質問があります。

「ある指定範囲において、列Bと列Cの情報が一致する行が複数あるとき、列Eに記載されている日付と時間が最新である行を残し、それ以外の行は削除する。」
こういった、処理を行うにはどうすればよいでしょうか。
ご回答お願いいたします。

回答の条件
  • 1人2回まで
  • 登録:2009/01/23 14:23:38
  • 終了:2009/01/27 19:05:29

回答(4件)

id:an_shoku_panman No.1

an_shoku_panman回答回数14ベストアンサー獲得回数02009/01/23 15:21:53

ポイント23pt

必ず予備のデータを準備の上御使用下さい。

データ作業範囲がA列の4行目からE列の100行目とした場合。

セルに以下の数式を入力し、マクロを標準モジュールに記載を

お願いします。

G1=データ開始列を数値で入力します。Aなら1 Bなら2 Eの場合は5という感じです。

G2=データ最終列を数値で入力します。上記と同じ形式です。

H1=SUMPRODUCT((A4:E100=MIN(A4:E100))*ROW(A4:E100))

H2=J1+1

I1=J1-1

I2=SUMPRODUCT((A4:E100=MAX(A4:E100))*ROW(A4:E100))

J1=ROW(INDEX(G:G,MATCH(10^17,G:G,1)))

他にも作業行・列がある場合お手数ですが変更お願いします。

Sub 一定範囲の消去()

データ開始列 = Range("G1").Value

データ最終列 = Range("G2").Value

データ開始行A = Range("H1").Value

データ開始行B = Range("H2").Value

データ最終行A = Range("I1").Value

データ最終行B = Range("I2").Value

Range(Cells(データ開始行A, データ開始列), Cells(データ最終行A, データ最終列)).Select

Selection.ClearContents

Range(Cells(データ開始行B, データ開始列), Cells(データ最終行B, データ最終列)).Select

Selection.ClearContents

End Sub

削除は問題がでる可能性もあり消去としました。(_ _)

id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/23 15:45:02

ポイント23pt

こんな感じのマクロではどうでしょうか。

選択した範囲で最新の日付以外の行を削除します。

Sub Macro()
    Dim r As Range
    Dim maxDate As Date
    Dim maxRow As Long
    
    maxRow = 65536
    For Each r In Selection
        If r.Column = 2 Then
            If Cells(r.Row, 2).Value = Cells(r.Row, 3).Value Then
                If maxDate < Cells(r.Row, 5).Value Then
                    Rows(maxRow).Delete
                    maxRow = r.Row
                    maxDate = Cells(r.Row, 5).Value
                Else
                    Rows(r.Row).Delete
                End If
            End If
        End If
    Next r
End Sub
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692009/01/23 21:48:09

ポイント22pt

大変失礼しました。先の回答には間違いがありました。

修正したものを回答します。

注意。選択した範囲の行を削除しますが、複数箇所の選択には対応していません。

Sub Macro()
    Dim firstRow As Long
    Dim lastRow As Long
    Dim i As Long
    Dim maxDate As Date
    Dim maxRow As Long
    
    firstRow = Selection.Row
    lastRow = Selection.Row + Selection.Rows.Count - 1
    
    maxRow = 65536
    For i = lastRow To firstRow Step -1
        If Cells(i, 2).Value = Cells(i, 3).Value Then
            If maxDate < Cells(i, 5).Value Then
                Rows(maxRow).Delete
                maxRow = i
                maxDate = Cells(i, 5).Value
            Else
                Rows(i).Delete
            End If
        End If
    Next i
End Sub
id:ardarim No.4

ardarim回答回数897ベストアンサー獲得回数1452009/01/24 18:09:00

ポイント22pt

間違いがあるといけないので、データはバックアップを取ってから試してください。

Option Explicit
Option Base 0

Sub test()

    Dim r1 As Range, r2 As Range
    Dim r1_row As Long
    Dim r1_dataB As Variant, r1_dataC As Variant, r1_dataE As Variant
    Dim rowsToBeRemoved() As Long
    Dim removeRows As Long
    Dim i As Long, j As Long
    Dim r As Long, mr As Long
    
    removeRows = 0
    ReDim rowsToBeRemoved(0)
    
    ' 選択範囲がセルでない場合は終了
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    ' セル全選択されている場合などを考慮し、有効データ範囲のみ対象とする
    mr = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
    
    ' 選択範囲内の行を上から順に走査
    For Each r1 In Selection.Rows
        r1_row = r1.Row
        If r1_row > mr Then Exit For
        r1_dataB = Cells(r1_row, 2).Value
        r1_dataC = Cells(r1_row, 3).Value
        r1_dataE = Cells(r1_row, 5).Value
        ' 重複検査のため選択範囲内の行を上から順に走査
        For Each r2 In Selection.Rows
            If r2.Row > mr Then Exit For
            If r2.Row > r1_row Then
                If Cells(r2.Row, 2).Value = r1_dataB And Cells(r2.Row, 3).Value = r1_dataC Then
                    If r1_dataE <= Cells(r2.Row, 5).Value Then
                        r = r1_row
                    Else
                        r = r2.Row
                    End If
                    ' 既に削除対象になっているか確認し
                    For i = 1 To removeRows
                        If rowsToBeRemoved(i) = r Then Exit For
                    Next i
                    If i > removeRows Then
                        ' 対象になっていなければ追加(行番号が小さい順)
                        removeRows = removeRows + 1
                        ReDim Preserve rowsToBeRemoved(removeRows)
                        For i = 1 To removeRows - 1
                            If rowsToBeRemoved(i) > r Then
                                For j = removeRows To i + 1 Step -1
                                    rowsToBeRemoved(j) = rowsToBeRemoved(j - 1)
                                Next j
                                rowsToBeRemoved(i) = r
                                Exit For
                            End If
                        Next i
                        If i = removeRows Then
                            rowsToBeRemoved(removeRows) = r
                        End If
                    End If
                End If
            End If
        Next r2
    Next r1

    ' 削除対象の行を順に削除
    If removeRows >= 1 Then
        For i = removeRows To 1 Step -1
            Rows(rowsToBeRemoved(i)).Delete
        Next i
    End If

End Sub

やることは単純なんですが、ちゃんとやると面倒くさいですね。

コメントはまだありません

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません