black-holeの日記: Excel/VBA入門: 空白セルに上位セルの値をコピーする。
とりあえず、表題の通り。
ただし、空白セルに上位セルの値をコピーするだけなら、空白セルを全選択して上位セルへの参照を一括入力するだけで良いので、ひと工夫してみた。
誰かの作った階層形式の表をリスト形式(データベース形式)に変換したいときなどにどうぞ。
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
以上
Excel/VBA入門: 空白セルに上位セルの値をコピーする。 More ログイン