2014-06-14

VBAでワークシート上にある全ての文言を取得する方法について書きます。

１．オートシェイプ（図形）の文言を取得する

セル内の文言はRange("A1").Valueなどで簡単に取得できますが、

以下の様なオートシェイプ（図形）に含まれる文言は

ShapesオブジェクトのTextFrameプロパティから取得する必要があります。

Shepes.TextFrameプロパティ

[サンプル]

以下のサンプルでは、アクティブシート上にある1番目の図形から、レイアウト枠内のテキスト表示します。

MsgBox ActiveSheet.Shapes(1).TextFrame.Characters.text

（実行例）

Shapes()の引数は図形の名称でも構いません。

直線など、図形にレイアウト枠がない場合、エラーとなります。

２．シート上にある全てのオートシェイプ（図形）から文言を取得する

以上の内容をもとに、シート上にある全てのオートシェイプから文言を取得するFunctionを作成しました。

[ソース]

Public Function getShapesProperty(bookName As String, sheetName As String) As String()

'------------------------------------------

'getShapesText

'対象シート上にあるオブジェクトのプロパティを取得する

'引数１：bookName as String   対象ブック名

'引数２：sheetName as String   対象シート名

'戻り：getShapesProperty as string(2,n)

'          (0,n) .type

'          (1,n) .name

'          (2,n) .TextFrame.Characters.text

'          (3,n) .Left

'          (4,n) .Top

'          (5,n) .Width

'          (6,n) .Height

'          (7,n) .TopLeftCell.Address(False, False)

'          (8,n) .BottomRightCell.Address(False, False)

'

'------------------------------------------

    Dim ret() As String

    Dim i As Long

    Dim obj As Object



    For Each obj In Workbooks(bookName).Sheets(sheetName).Shapes

        ReDim Preserve ret(8, i) As String

        ret(0, i) = CStr(obj.Type)

        ret(1, i) = CStr(obj.Name)



        'TextFrameプロパティが使用できない(レイアウト枠がない)オブジェクトは除外

        On Error Resume Next

        ret(2, i) = obj.TextFrame.Characters.text



        ret(3, i) = CStr(obj.Left)

        ret(4, i) = CStr(obj.Top)

        ret(5, i) = CStr(obj.Width)

        ret(6, i) = CStr(obj.Height)

        ret(7, i) = CStr(obj.TopLeftCell.Address(False, False))

        ret(8, i) = CStr(obj.BottomRightCell.Address(False, False))



        i = i + 1

    Next



    getShapesProperty = ret



End Function

引数にはブック名・シート名を指定します。

文言のほか、図形の幅などの情報も持たせたString配列を返却します。

レイアウト枠がない図形は、エラーをスキップして処理しています(On Error Resume Next)。

（もう少しきれいな方法があれば良かったんですが。。。）

２．１．テストしてみる（オートシェイプの文言取得）

以下のソースを実行して、テストしてみます。

[テストコード]

Sub test_getShepesProperty()



    Dim str() As String

    str = getShapesProperty(ThisWorkbook.name, ActiveSheet.name)



    Dim msg As String

    Call addMsg(msg, "オートシェイプのプロパティを取得")



    Dim i As Long

    For i = 0 To UBound(str, 2)

        Call addMsg(msg, "図形：" + CStr(i + 1))

        Call addMsg(msg, "図形種別(.Type)：" + str(0, i))

        Call addMsg(msg, "名称(.Name)：" + str(1, i))

        Call addMsg(msg, "文言(.TextFrame.Characters.text)：" + str(2, i))

        Call addMsg(msg, "左位置(.Left)：" + str(3, i))

        Call addMsg(msg, "上位置(.Top)：" + str(4, i))

        Call addMsg(msg, "幅(.Width)：" + str(5, i))

        Call addMsg(msg, "高さ(.Height)：" + str(6, i))

        Call addMsg(msg, "図形左上のセル(.TopLeftCell.Address)：" + str(7, i))

        Call addMsg(msg, "図形右下のセル(.BottomRightCell.Address)：" + str(8, i))

        Call addMsg(msg)

    Next i



    MsgBox msg



End Sub

Sub addMsg(msg As String, Optional addMsg = "")

    msg = msg + addMsg + vbCrLf

End Sub

以下はテスト用のシートです。

（test_getShepesProperty()を実行）

↓

全てのオートシェイプから、文言を取得することができました。

３．シート上の全てのセル内の文言を取得する

一応、セル内の文言を取得するFunctionも作成しました。

[ソース]

Function getTextOnCell(bookName As String, sheetName As String) As String()

'------------------------------------------

'getTextOnCell

'対象シート上にあるセル内の文言を取得する

'

'戻り：getTextOnCell as string(2,n)

'          (0,n) 行

'          (1,n) 列

'          (2,n) 文言

'

'------------------------------------------

    Workbooks(bookName).Sheets(sheetName).Activate



    Dim ret() As String

    Dim r As Long  'ret()用カウンタ



    Dim sRow As Long

    Dim sCol As Long

    Dim lRow As Long

    Dim lCol As Long

    sRow = 1

    sCol = 1

    Call getRange(sheetName, lRow, lCol)



    'データ

    Dim i As Long

    Dim j As Long

    Dim str As String

    For i = sRow To lRow

        For j = sCol To lCol

            str = Workbooks(bookName).Sheets(sheetName).Cells(i, j).Value

            If str <> "" Then

                ReDim Preserve ret(2, r) As String

                ret(0, r) = CStr(i)

                ret(1, r) = CStr(j)

                ret(2, r) = str

                r = r + 1

            Else

                '処理なし

            End If

        Next j

    Next i



    getTextOnCell = ret



End Function

Sub getRange(sheetName As String, lRow As Long, lCol As Long)

'------------------------------------------------------------------------------------

'getRange

'シート最終行列の設定

'引数１：sheetName・・・・・・シート名

'引数２：lRow ・・・・・・・・最終行

'引数３：lCol ・・・・・・・・最終列

'

'------------------------------------------------------------------------------------

    s = Sheets(sheetName).UsedRange.Address              '有効レンジ範囲

    lRow = Range(s).Rows(Range(s).Rows.count).Row               '最終行

    lCol = Range(s).Columns(Range(s).Columns.count).Column      '最終列

End Sub

引数にはブック名、シート名を指定します。

セル(1, 1)から最終セルまでの文言を取得し、String配列で返却します。

３．２．テストしてみる（セル内の文言取得）

以下のテストコードを実行し、テストしてみます。

Sub test_getTextOnCell()



    Dim str() As String

    str = getTextOnCell(ThisWorkbook.name, ActiveSheet.name)



    Dim msg As String

    Call addMsg(msg, "セル内の文言一覧")

    Call addMsg(msg)



    Dim i As Long

    For i = 0 To UBound(str, 2)

        Call addMsg(msg, "行：" + str(0, i))

        Call addMsg(msg, "列：" + str(1, i))

        Call addMsg(msg, "文言：" + str(2, i))

        Call addMsg(msg)

    Next i



    MsgBox msg



End Sub

Sub addMsg(msg As String, Optional addMsg = "")

    msg = msg + addMsg + vbCrLf

End Sub

以下はテスト用シートです。

(test_getTextOnCell()を実行)

↓

以上の通り、セル内の文言を取得できました。

今回作成した2つのFunctionで、シート上の全ての文言を取得できます。

Sumihirablog.

VBAで（オートシェイプ（図形）を含めた）シート上の全ての文言を取得する

１．オートシェイプ（図形）の文言を取得する

２．シート上にある全てのオートシェイプ（図形）から文言を取得する

２．１．テストしてみる（オートシェイプの文言取得）

３．シート上の全てのセル内の文言を取得する

３．２．テストしてみる（セル内の文言取得）