サポート掲示板


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


[37] 修正メモ
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

返信する


関連ツリー
-修正メモ [takana] (2010/03/18 17:05)

 返信フォーム [引用]

 名前 *
 E-Mail
 題名 *

タグ使用可 <b><i><s><font>
 URL
 Pass  設定すれば、投稿後に削除や編集ができます


Pass

トップページへ

レッツPHP!