パスワードを忘れた? アカウント作成
269890 journal

black-holeの日記: Excel/VBA入門: 空白セルに上位セルの値をコピーする。

日記 by black-hole

とりあえず、表題の通り。
ただし、空白セルに上位セルの値をコピーするだけなら、空白セルを全選択して上位セルへの参照を一括入力するだけで良いので、ひと工夫してみた。
誰かの作った階層形式の表をリスト形式(データベース形式)に変換したいときなどにどうぞ。

Sub CopyHigherToBlankCell()
    '
    ' 選択範囲のセルについて、セルの値が空白の場合、上位のセルの値をコピーする。
    ' ただし、上位セルの参照は選択範囲までとする。
    ' また、コピー対象のセルの左側に値の境界がある場合、値のコピーはそこまでとする。
    ' ただし、値の境界のチェックは選択範囲までとする。
    '
    ' 2010/11/02 black-hole: 新規作成。
    ' 2010/11/03 black-hole: 一寸修正。
    '
    Dim lastCellRow As Long
    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 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
 
            '
            ' 下方向に次の値を検索
            '
            For jRow = iRow + 1 To lastRow
 
                '
                ' 次の値を検出したら検索終了
                '
                If Cells(jRow, iColumn).Value <> "" Then
                    Exit For
                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
                str = Cells(iRow, iColumn).Value
                If str <> "" Then
'                    Range(Cells(iRow + 1, iColumn), Cells(jRow - 1, iColumn)).Interior.ColorIndex = 6 ' テスト用
                    Range(Cells(iRow + 1, iColumn), Cells(jRow - 1, iColumn)).Value = str
                End If
            End If
 
            iRow = jRow
        Loop
    Next
End Sub

以上

この議論は賞味期限が切れたので、アーカイブ化されています。 新たにコメントを付けることはできません。
typodupeerror

目玉の数さえ十分あれば、どんなバグも深刻ではない -- Eric Raymond

読み込み中...