EXCELオブジェクトを使って結合セルの値を取得

解決

---

掲題の通り、結合されたセルの値をVBからEXCELオブジェクトを使用して取得したいのです。
ですが、このとき結合されたセルの左上座標を指定しないと値が取得できません。
（たとえばA1,A2,B1,B2が結合されている場合A1以外は0が帰ってしまいます。）
このとき、結合されている範囲のどの座標でもその結合セルの値が返るようにする方法はありませんでしょうか？

以下にサンプルを示します。
Option Explicit

Private Sub Command1_Click()
Screen.MousePointer = vbHourglass

Dim objExcel As New Excel.Application
Dim objBook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim objRange As Excel.Range

objExcel.Workbooks.Open App.Path & "\Book1.xls"
Set objBook = objExcel.Workbooks("Book1.xls")
Set objSheet = objBook.Worksheets("Sheet1")

With objSheet
    Text1.Text = Text1.Text & "A1" & vbTab & .Cells(1, 1) & vbCrLf
    Text1.Text = Text1.Text & "B1" & vbTab & .Cells(2, 1) & vbCrLf
    Text1.Text = Text1.Text & "C1" & vbTab & .Cells(3, 1) & vbCrLf
    Text1.Text = Text1.Text & "D1" & vbTab & .Cells(4, 1) & vbCrLf
    Text1.Text = Text1.Text & vbCrLf
    Text1.Text = Text1.Text & "A2" & vbTab & .Cells(1, 2) & vbCrLf
    Text1.Text = Text1.Text & "B2" & vbTab & .Cells(2, 2) & vbCrLf
    Text1.Text = Text1.Text & "C2" & vbTab & .Cells(3, 2) & vbCrLf
    Text1.Text = Text1.Text & "D2" & vbTab & .Cells(4, 2) & vbCrLf

End With

    objExcel.Quit
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objExcel = Nothing
Screen.MousePointer = vbDefault
End Sub

どうぞ、よろしくお願いします。

編集 削除

---

こんな感じですね。

Option Explicit

Private Sub Command1_Click()
Screen.MousePointer = vbHourglass

Dim objExcel As New Excel.Application
Dim objBook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Dim objRange As Excel.Range

objExcel.Workbooks.Open App.Path & "\Book1.xls"
Set objBook = objExcel.Workbooks("Book1.xls")
Set objSheet = objBook.Worksheets("Sheet1")

With objSheet
    Text1.Text = Text1.Text & "A1" & vbTab & MergeCellsValue(.Cells(1, 1)) & vbCrLf
    Text1.Text = Text1.Text & "B1" & vbTab & MergeCellsValue(.Cells(2, 1)) & vbCrLf
    Text1.Text = Text1.Text & "C1" & vbTab & MergeCellsValue(.Cells(3, 1)) & vbCrLf
    Text1.Text = Text1.Text & "D1" & vbTab & MergeCellsValue(.Cells(4, 1)) & vbCrLf
    Text1.Text = Text1.Text & vbCrLf
    Text1.Text = Text1.Text & "A2" & vbTab & MergeCellsValue(.Cells(1, 2)) & vbCrLf
    Text1.Text = Text1.Text & "B2" & vbTab & MergeCellsValue(.Cells(2, 2)) & vbCrLf
    Text1.Text = Text1.Text & "C2" & vbTab & MergeCellsValue(.Cells(3, 2)) & vbCrLf
    Text1.Text = Text1.Text & "D2" & vbTab & MergeCellsValue(.Cells(4, 2)) & vbCrLf

End With

    objExcel.Quit
    Set objSheet = Nothing
    Set objBook = Nothing
    Set objExcel = Nothing
Screen.MousePointer = vbDefault
End Sub

Private Function MergeCellsValue(objRange As Excel.Range) As Variant
    Dim RowOffset As Long
    Dim ColOffset As Long
    Dim lngRow As Long
    Dim lngCol As Long
    
    If objRange.MergeCells = True Then
        RowOffset = 0
        ColOffset = 0
        For lngRow = objRange.Row - 1 To 1 Step -1
            If Cells(lngRow, objRange.Column).MergeCells = True Then
                RowOffset = RowOffset - 1
            End If
        Next lngRow
        
        For lngCol = objRange.Column - 1 To 1 Step -1
            If Cells(objRange.Row, lngCol).MergeCells = True Then
                ColOffset = ColOffset - 1
            End If
        Next lngCol
        
        MergeCellsValue = objRange.Offset(RowOffset, ColOffset).Value
    Else
        MergeCellsValue = objRange.Value
    End If
End Function

編集 削除

---

LESIA様、ご返答ありがとうございました。
おかげさまで、値を見事取得することができました。
やはり、ループで結合セルの左上の座標を求めるのが定石のようですね。

ありがとうございました。
また何かありましたらよろしくお願いします。

編集 削除

---

MergeCellsValue関数を使うと別の結合セルが隣にあった場合おかしくなります。

よく考えたら、MergeAreaプロパティを使えば出来ますね(^^;

With objSheet
    Text1.Text = Text1.Text & "A1" & vbTab & .Cells(1, 1).MergeArea.Cells(1, 1).Value & vbCrLf
    Text1.Text = Text1.Text & "B1" & vbTab & .Cells(2, 1).MergeArea.Cells(1, 1).Value & vbCrLf
    Text1.Text = Text1.Text & "C1" & vbTab & .Cells(3, 1).MergeArea.Cells(1, 1).Value & vbCrLf
    Text1.Text = Text1.Text & "D1" & vbTab & .Cells(4, 1).MergeArea.Cells(1, 1).Value & vbCrLf
    Text1.Text = Text1.Text & vbCrLf
    Text1.Text = Text1.Text & "A2" & vbTab & .Cells(1, 2).MergeArea.Cells(1, 1).Value & vbCrLf
    Text1.Text = Text1.Text & "B2" & vbTab & .Cells(2, 2).MergeArea.Cells(1, 1).Value & vbCrLf
    Text1.Text = Text1.Text & "C2" & vbTab & .Cells(3, 2).MergeArea.Cells(1, 1).Value & vbCrLf
    Text1.Text = Text1.Text & "D2" & vbTab & .Cells(4, 2).MergeArea.Cells(1, 1).Value & vbCrLf
End With

編集 削除

---

なるほど、MergeAreaプロパティはこのように使うのですね。
道理でobjSheet.MergeArea(1,1)のように書くとエラーになるのはあたりまえですね。勉強不足でした。
LESIA様、追記ありがとうございました。

編集 削除

---

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

←解決時は質問者本人がここをチェックしてください。