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様、追記ありがとうございました。
| ツイート |  |