サポート掲示板

　新規投稿　｜　タイトル一覧　-　ツリー　-　スレッド　-　投稿一覧　｜　検索　｜　設定　

No.37に関するツリー

▼-修正メモ [takana] (2010/03/18 17:05)

Name: takana Date: 2010/03/18 17:05

'*****************************************************************************
'[ 関数名 ]　CopyVerticalBorder
'[ 概要 ]　行の縦罫線をコピーする
'[ 引数 ]　objFromRow：コピ－元の行、objToRow：コピー先の行
'[ 戻り値 ]　なし
'*****************************************************************************
Private Sub CopyVerticalBorder(ByRef objFromRow As Range, ByRef objToRow As Range)
Dim i As Long
Dim udtBorder(0 To 1) As TBorder '罫線の種類(左･右)
Dim lngLast As Long

If objFromRow.Columns.Count = Columns.Count Then
'最後のセルまで整備すれば終了する
lngLast = Cells.SpecialCells(xlCellTypeLastCell).Column
Else
'選択されたすべての列を整備する
lngLast = objFromRow.Columns.Count
End If

'1列毎にループ
For i = 1 To lngLast
'コピ－元のセルの罫線の種類を保存
udtBorder(0) = GetBorder(objFromRow.Columns(i).Borders(xlEdgeLeft))
udtBorder(1) = GetBorder(objFromRow.Columns(i).Borders(xlEdgeRight))
'コピー先のセルにコピー
Call SetBorder(udtBorder(0), objToRow.Columns(i).Borders(xlEdgeLeft))
Call SetBorder(udtBorder(1), objToRow.Columns(i).Borders(xlEdgeRight))
Next i
End Sub

'*****************************************************************************
'[ 関数名 ]　CopyBottomBorder
'[ 概要 ]　行の下端の罫線をコピーする
'[ 引数 ]　objFromRow：コピ－元の行、objToRow：コピー先の行
'[ 戻り値 ]　なし
'*****************************************************************************
Private Sub CopyBottomBorder(ByRef objFromRow As Range, ByRef objToRow As Range)
Dim i As Long
Dim udtBorder As TBorder '下端の罫線の種類
Dim lngLast As Long

If objFromRow.Columns.Count = Columns.Count Then
'最後のセルまで整備すれば終了する
lngLast = Cells.SpecialCells(xlCellTypeLastCell).Column
Else
'選択されたすべての列を整備する
lngLast = objFromRow.Columns.Count
End If

'1列毎にループ
For i = 1 To lngLast
'コピ－元のセルの罫線の種類を保存
udtBorder = GetBorder(objFromRow.Columns(i).Borders(xlEdgeBottom))
'コピー先のセルにコピー
Call SetBorder(udtBorder, objToRow.Columns(i).Borders(xlEdgeBottom))
Next i
End Sub