EXCELオブジェクトを使って結合セルの値を取得 (ID:87043)

名前

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

本文 こんな感じですね。 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