black-holeの日記： Excel/VBA入門： セルに同じ値が連続している場合、一番上を残して下位の値をクリアする。

今日は休日(文化の日)。
昨日上げたものの逆変換も欲しいよね、ということでもう一個。
まあ、リスト形式の方が便利なので、セルを空白にするよりフォントの色を目立たなくした方が良いかも。

Sub ClearLowerCell()
    '
    ' 選択範囲のセルについて、同じ列のセルに同じ値が連続している場合、一番上の値を残して下位の値をクリアする。
    ' ただし、セルの参照は選択範囲内までとする。
    ' また、クリア対象のセルの左側に値の境界がある場合、値のクリアはそこまでとする。
    ' ただし、値の境界のチェックは選択範囲までとする。
    '
    ' 2010/11/03 black-hole: 新規作成。
    '
    Dim lastCellColumn As Long
    Dim startRow As Long
    Dim startColumn As Long
    Dim lastRow As Long
    Dim lastColumn As Long
    Dim iRow As Long
    Dim iColumn As Long
    Dim jRow As Long
    Dim jColumn As Long
    Dim strTop As String
    Dim str As String
 
    '
    ' 選択範囲を取得
    '
    startRow = Selection.Rows(1).Row
    startColumn = Selection.Columns(1).Column
    lastRow = Selection.Rows(Selection.Rows.Count).Row
    lastColumn = Selection.Columns(Selection.Columns.Count).Column
 
    '
    ' 実際の処理範囲は値が存在するセルまで
    '
    lastCellRow = Cells.SpecialCells(xlCellTypeLastCell).Row
    lastCellColumn = Cells.SpecialCells(xlCellTypeLastCell).Column
 
    If lastRow > lastCellRow Then
        lastRow = lastCellRow
    End If
    If lastColumn > lastCellColumn Then
        lastColumn = lastCellColumn
    End If
 
    '
    ' 選択範囲を左列→右列、上行→下行の順に処理
    '
    For iColumn = startColumn To lastColumn
 
        iRow = startRow
        Do While iRow < lastRow
            strTop = Cells(iRow, iColumn).Value
 
            '
            ' 下方向に次の値を検索
            '
            For jRow = iRow + 1 To lastRow
 
                '
                ' 次の値を検出したら検索終了
                '
                str = Cells(jRow, iColumn).Value
                If str <> "" Then
                    If StrComp(str, strTop, vbBinaryCompare) <> 0 Then
                        Exit For
                    End If
                End If
 
                '
                ' 左側のセルに値の境界を検出したら検索終了
                '
                jColumn = startColumn
                Do While jColumn < iColumn
                    str = Cells(jRow, jColumn).Value
                    If str <> "" Then
                        If StrComp(str, Cells(iRow, jColumn).Value, vbBinaryCompare) <> 0 Then
                            Exit For ' For jRowを終了
                        End If
                    End If
                    jColumn = jColumn + 1
                Loop
            Next
 
            '
            ' セルの値をクリア
            '
            If jRow > iRow + 1 Then
                If strTop <> "" Then
'                    Range(Cells(iRow + 1, iColumn), Cells(jRow - 1, iColumn)).Interior.ColorIndex = 6 ' テスト用
'                    Range(Cells(iRow + 1, iColumn), Cells(jRow - 1, iColumn)).Font.ColorIndex = 15
                    Range(Cells(iRow + 1, iColumn), Cells(jRow - 1, iColumn)).Value = ""
                End If
            End If
 
            iRow = jRow
        Loop
    Next
End Sub

以上