サポート掲示板

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

No.31に関するツリー

▼-メモ [takana] (2009/01/08 17:06)
　└Re:メモ [takana] (2009/01/08 17:07)
　　└Re[2]:メモ [Dalton] (2016/08/07 21:00)

Name: takana Date: 2009/01/08 17:06

'*****************************************************************************
'[ 関数名 ]　GetDoRange
'[ 概要 ]　横方向の結合セルがある時、一番結合幅が広いセルのみ実行対象とする
'[ 引数 ]　選択されたセル
'[ 戻り値 ]　実行対象のセル
'*****************************************************************************
Private Function GetDoRange(ByRef objSelection As Range) As Range
Dim objArea As Range
Dim i As Long
Dim objLeftCol As Range
Dim objRightCol As Range
Dim objWkRange(1 To 2) As Range
Dim lngMaxMergeWidth As Long
Dim objMergeCol As Range

For Each objArea In objSelection.Areas
For i = 1 To objArea.Columns.Count
Set objMergeCol = GetMergeCol(objArea.Columns(i).EntireColumn, objSelection)
Set objLeftCol = objMergeCol.Columns(1)
Set objRightCol = objMergeCol.Columns(objMergeCol.Columns.Count)
Set objWkRange(1) = ArrangeRange(Intersect(objLeftCol, objSelection))
Set objWkRange(2) = ArrangeRange(Intersect(objRightCol, objSelection))
Set GetDoRange = UnionRange(GetDoRange, Intersect(objWkRange(1), objWkRange(2)))
i = i + objMergeCol.Columns.Count - 1
Next i
Next
End Function

返信する

[32] Re:メモ

Name: takana Date: 2009/01/08 17:07

'*****************************************************************************
'[ 関数名 ]　GetMaxMergeWidth
'[ 概要 ]　横方向の結合の最大幅を取得する
'[ 引数 ]　調査する領域、左端のColumn番号
'[ 戻り値 ]　なし
'*****************************************************************************
Private Function GetMergeCol(ByRef objCol As Range, ByRef objSelection As Range) As Range
Dim objRange As Range
Dim objWkRange As Range

Set objWkRange = ArrangeRange(Intersect(objCol, objSelection))

'選択範囲のColumnsの和集合を取り重複列を排除する
Set objRange = Union(objWkRange.EntireColumn, objWkRange.EntireColumn)

While (True)
Set objWkRange = ArrangeRange(Intersect(objRange, objSelection))

'選択範囲のColumnsの和集合を取り重複列を排除する
Set GetMergeCol = Union(objWkRange.EntireColumn, objWkRange.EntireColumn)

If GetMergeCol.Address = objRange.Address Then
Exit Function
End If
Set objRange = GetMergeCol
Wend
End Function