[[20160219124019]]　『図形（正方形/長方形）の中の文字抽出』（オグ09）　ページの最後に飛ぶ

『図形（正方形/長方形）の中の文字抽出』（オグ09）

図形（正方形/長方形）の中の文字抽出について

現在仕事にて当日のスケジュールシートをエクセルで作成し運用しています。
情報量が増えた？せいもあるのかもしれませんが、スケジュールをシートに
図形（正方形/長方形）で横並びで時間軸に沿って貼り付けています。

図形の中には行先や、搬送経路、出発時間、現地到着時間、緊急連絡先が入力されていますが、その図形の中の文字を抽出するのに時間がかかってしまい、ちょっとイライラしています。

抽出コードは以下のコードです。

Sub A_LINE_DATA抽出()

    Dim rng(1) As Range

    Set rng(0) = ActiveSheet.Range("R8:FB10") '読み取り範囲
    Set rng(1) = Sheets("午前SKD").Range("EA6") '出力位置
    rng(1).EntireColumn.ClearContents '出力列のクリア
    Call MainGetText(rng(0), rng(1)) 'メイン処理へ

End Sub
'******************************************************************************
' 共通処理　引数はオブジェクト型とする
' 読み取り範囲：TargetRange0
' 出力位置（先頭セル）：TargetRange1
'******************************************************************************
Private Sub MainGetText(TargetRange0 As Range, Targetrange1 As Range)

    Dim myText As Variant

    myText = GetShapeText(TargetRange0) 'ユーザー定義関数による処理

    If InStr(myText, ",") > 0 Then
        'テキストが複数件ある場合の処理
        myText = Split(myText, ",")
        myText = Application.WorksheetFunction.Transpose(myText)
        '出力するセルの先頭を指定
        Targetrange1.Resize(UBound(myText)).Value = myText
    Else
        'テキストが1件の場合もしくは0件の処理
        Targetrange1.Value = myText
    End If
End Sub

'******************************************************************************
' ユーザー定義型関数　引数は検索範囲をオブジェクト型とする
'　　　　　　　　　　戻り値はカンマ区切りの文字列となる
'******************************************************************************
Private Function GetShapeText(rng As Range) As Variant

    Dim buf As Variant
    Dim lngLeft   As Long
    Dim lngTop    As Long
    Dim lngRight As Long
    Dim lngBottom As Long
    Dim objShape As Object

    ' セル範囲の座標取得
    With rng
        lngTop = .Top
        lngLeft = .Left
        lngBottom = .Top + .Height
        lngRight = .Left + .Width
    End With
    ' アクティブシートの図形列挙
    For Each objShape In ActiveSheet.DrawingObjects     'TextBoxes '四角形のみ
        ' 範囲内にあるかチェック
        With objShape
            If lngTop <= .Top And lngBottom >= .Top + .Height And lngLeft <= .Left And lngRight >= .Left + .Width Then
                ' 範囲内にあればテキストを取得
                On Error Resume Next 'テキストの無い図形の場合はエラーになるため処理を飛ばす
                buf = buf & .Text & ","
                On Error GoTo 0 'エラーの初期化
            End If
        End With
    Next
    If InStr(buf, ",") > 0 Then
        GetShapeText = Left(buf, Len(buf) - 1)
    Else
        GetShapeText = buf
    End If
End Function

午前のスケジュールではA-ライン（3行1SET）からZラインまであり、各行には
図形（正方形/長方形）や、テキストボックス、矢印図形等色々あります。
正方形/長方形のデータだけ抜き取りたいのです。

上記のコードでかなり時間がかかる（全ライン抽出で約3分くらい）ので、
時短をして効率を上げたいのですが何か時短の方法はありますでしょうか？

また、こんな面倒なコードを使わなくても視点をかえて簡単な方法はありますでしょうか？
ご指導いただけたら幸いです。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 アップされたコードの構成は、ラインごとに、シート上の全四角形を抽出し、
 その四角形がライン領域にあるものを、対象としていますね。

 ・まず、シート状の四角形を、そのテキストとともに　すべて抽出。
 　それをその TopLeftCell あたりが、分析したいすべてのライン領域のどこに入っているかのテーブルというか
 　そういった情報を準備。（Dictionary を使うのが簡単だと思いますが）

 ・各ライン処理では、単純に、そのテーブルから、当該ラインの四角形のみを抜き出して淡々と処理する。

 このような構成にされてはいかがですか。

 　
（β） 2016/02/19(金) 13:24

 それと、コードを見る限り抽出しているのは

 For Each objShape In ActiveSheet.DrawingObjects  ですから

 DrawingObjectすべて、いいかえると、四角形のみではないです。
 また、コードコメントに　'TextBoxes '四角形のみ　とあるのが気になります。

 実際に取り出したいのは四角形ですか？　フォームツールの TextBox ですか？　それとも？

（β） 2016/02/19(金) 15:13

(β)さん、ありがとうございました。
'TextBoxes '四角形のみに関しては以前は'TextBoxes だけでやっていたのでそれをそのまま残してある
だけです。
3行1SETで四角形が数個、時間列で横に並んでいます。
縦列は5分刻みの時間軸です。

Sub A_LINE_DATA抽出()の部分がZラインまであるので、少し時間がかかるのかな？と
思っていましたが。。。。

3行1SETの行には四角形とテキストボックス、矢印図形とうさまざまなものがあります。
その中で図形（正方形/長方形）のデータだけ抜き出したいと言う事です。
それで少しは時短になるのかな？と思いましたが、図形（正方形/長方形）だけ残しても
時間が変わらないので、良い案があるならと思い質問した次第です。
（オグ09） 2016/02/19(金) 15:40

 時短に関しては、できるところはできる、できないところはできないと、当たり前ですが。
 ただ、コメントしたように現行のコード構成より時短は可能だと思っています。

 で、さらに時短の可能性があるとしたら、たとえば、このシートの四角形を増減させたり、四角形ないの文字を変更した際に
 忘れずに、決められたマクロを実行するという運用ができるなら、さらなる時短が望めます。

 運用上難しいということなら、たとえば、ブックを開いた時点からマクロ実行するまで、少なくとも四角形の増減はない。
 ありうるとしたら、その中の文字列の変更のみ　という運用であれば、これだけでも、少なくない時短の余地はあります。

 実際の運用はどうなんでしょうか？

 (最悪はマクロ実行のたびにシート上の四角形をなめまわすということになりますが、最初にコメントしたように
  それであっても、工夫することで現行よりは少し時短が実現すると思いますが）

（β） 2016/02/19(金) 19:59

 それと、コードが、おそらく一部分だけなので、要件が明確に理解できていません。
 以下のようなことでいいのでしょうか？

 A～Zまでの各領域内の四角形のテキスト（テキストのないものは除く）を、それぞれ、どこかのシートのどこかのセル領域に転記。

 Aライン の領域は　シート　午前SKD　の EA6 を先頭にした EA列　ということはわかるのですが、そのほかのラインについては　コードからは見えません。
 具体的にはどこなんでしょうか？

（β） 2016/02/19(金) 20:49

 ↑　大見得を切りましたが、四角形の数によっては、なかなか時短になりませんねぇ。
 実際には、各ラインに、いくつぐらいの四角形が配置されていますか？

（β） 2016/02/19(金) 21:16

 コメントした通り、四角形の数が多ければ（こちらのテストでは、各ライン、すべてのセルに四角形を配置）
 なかなか時短が実現しませんね。

 まぁ、質問している点に回答いただければ、何か、工夫もできるかもしれません。

 ところで、

 >>その中で図形（正方形/長方形）のデータだけ抜き出したいと言う事です

 と書いておられるのですが、コードは指摘した通り

 For Each objShape In ActiveSheet.DrawingObjects

 になっていますね。これでは、すべての DrawingObject が取得されてしまいます。

 For Each objShape In ActiveSheet.Rectangles  でしょうね。

 いずれにしても、私が試しているように、全セルに四角形があるなら、これは、なかなか　やっかいだと思いますが
 逆に、そういうレイアウトなら、わざわざ四角形を配置してテキストとして書き込むより
 通常のセル文字列として入力しておけば、簡単ですし早くなりますよね。
 あるいは四角形を使わず、セルのコメントを利用すると、少しはやくなるのかなぁ・・・・

 いずれにしても、具体的なレイアウトイメージがわからないので、なんともいえませんが。

（β） 2016/02/19(金) 22:30

 参考までに。

 こちらでは Aライン、R8:FB10 の　423セル、それが下に Zラインまで続く、都合 10998 セルにすべて四角形を配置。

 この状態で、For Each objShape In ActiveSheet.DrawingObjects  であれ　For Each objShape In ActiveSheet.Rectangles  であれ
 このコードで、気が狂うくらいの時間がかかります。
 In で相手にするコレクションを呼び込もうとしているわけですが、これが　10998 オブジェクトもあるので
 そうなるのでしょうね。

 しかも、これは、このコードが現れるたびに、コレクションの呼び込みが発生するわけですから、
 現行、（推測ですけど）そちらのコードは、おそらく、AラインでもBラインでもCラインでも、MainGetText経由でGetShapeTextを実行していると思われますので

 気が狂うほど遅い x 26 の遅さになりますね。

 これを、私が申し上げたように、最初に一度、すべての四角形の情報をDictionaryなどに格納しておき、
 ラインごとの取り出しは、淡々と格納済みのものを取得すれば、遅い部分は1回になりますが、それでも
 10998 オブジェクトだと遅いですね。

 ちょっと思い付きで申し上げたこと、四角形のテキストではなく、そのライン領域のセルのコメントとして登録してあれば
 これは、かなり短い時間で処理できますね。

（β） 2016/02/20(土) 09:53

βさん、ありがとうございます。

連絡が遅れました。

四角形の数は横に多くて3行1セットですので、12個位、少なくても3個くらいですね。

朝5時に配送をスタートするので、四角形の中のデータは

　　　事務所　　　車番号　　行先
　　　出発時間　　経路　　　到着時間

とこんな感じで横へ自動で貼りついてくるのです。配送が多いときは休憩をはさみこの四角形が多く
貼りついてきます。そんな感じですね。
私も色々教わりながらマクロを使ってきているので、用語や、説明がへたくそですから、βさんにも
中々伝わらないと思います。

今のコードも教わりながらのコードですから、特に変更や、記述のし直しでも問題ないと思い
質問させていただきました。

単純に3行1セット・・・たとえば
1.2.3.行目で上記のような内容の四角形のデータを簡単に抜き出す事が出来れば何もこだわりはないのです。

SKDを貼り付けるコードは下記のコードを教わり運用しています。（現在は少しいじっていますが）

'ユーザー定義型
Type inDAT
Name As String
stTime As String
Car As String
To As String
Root As String
Tel As String
edTime As String
End Type

Sub Main()
'メイン処理
Dim dat() As inDAT '入力データ
Dim rg As Range 'シェイプ貼り付け範囲
Dim endRow As Integer, endCol As Integer 'データの行列の終端
Dim putRow As Integer, putcol(1) As Integer 'シェイプ貼り付け範囲（列方向）
Dim i As Integer, j As Integer 'ループカウンタ
'入力データをユーザー定義型変数へ配列格納
With ThisWorkbook.Sheets("データ入力シート")
endRow = .Cells(Rows.Count, 1).End(xlUp).Row
ReDim dat(1 To endRow - 1)
j = 1
For i = 2 To endRow
dat(j).Name = .Cells(i, 1).Value
dat(j).stTime = Format(.Cells(i, 2).Value, "hh:mm")
dat(j).Car = .Cells(i, 3).Value
dat(j).To = .Cells(i, 4).Value
dat(j).Root = .Cells(i, 5).Value
dat(j).Tel = .Cells(i, 6).Value
dat(j).edTime = Format(.Cells(i, 7).Value, "hh:mm")
j = j + 1
Next i
End With
'シェイプ作成範囲を求める
With ThisWorkbook.Sheets("SKDシート")
.DrawingObjects.Delete
endRow = .Cells(Rows.Count, 1).End(xlUp).Row
endCol = .Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To UBound(dat)
For j = 2 To endRow
If .Cells(j, 1).Value = dat(i).Name Then
putRow = j
Exit For
End If
Next j
For j = 2 To endCol
If Format(.Cells(1, j).Value, "hh:mm") = dat(i).stTime Then
putcol(0) = j
End If
If Format(.Cells(1, j).Value, "hh:mm") = dat(i).edTime Then
putcol(1) = j
Exit For
End If
Next j
Set rg = .Range(.Cells(putRow, putcol(0)), .Cells(putRow, putcol(1)))
Call PUT_SHAPE(rg, dat(i))
Next i
End With
Erase dat
Set rg = Nothing
Sheet2.Activate

End Sub

Private Sub PUT_SHAPE(rg As Range, txt As inDAT)
'シェイプ作成処理(貼り付け範囲,1件分のデータ)
Dim spTxt As String
Dim x As Integer
x = 5 '調整値(シェイプの高さ調整 0で隙間がなくなる)
'テキスト内容を作成
spTxt = txt.Car & Space(2)
spTxt = spTxt & txt.Root & Space(2)
spTxt = spTxt & txt.To & vbCrLf
spTxt = spTxt & txt.stTime & Space(2)
spTxt = spTxt & txt.Tel & Space(2)
spTxt = spTxt & txt.edTime
'シェイプ作成
With ThisWorkbook.Sheets("SKDシート").Shapes.AddShape _
(msoShapeRectangle, rg.Left, rg.Top + x / 2, rg.Width, rg.Height - x).TextFrame
.Characters.Text = spTxt
.Characters.Font.Size = 10
.HorizontalAlignment = xlHAlignCenter ' 中央揃え
.VerticalAlignment = xlVAlignCenter ' 中央揃え
End With
End Sub

（オグ09） 2016/02/21(日) 22:37

横から失礼します。
詳細を読んでいないので恐縮ですが、
元になったシートと図形内のテキストは
同期がとれている（図形にだけ修正を加えることはない）ということであれば、
図形のテキストを探しに行くよりも、
図形作成の元になったシート側の情報を取りにいったほうが
早いのではないですか？

（γ） 2016/02/21(日) 23:21

 データ入力シート と　SKDシート　のレイアウトを教えてもらえますか？
 （コードをおいかけて推測してください　というのは、ちょっと　つらいので）

 以下は余談です。

 インデントを付けないコード、学校の質問でもよく見かけますが、βから見ると（逆に）よく、このコードで
 ネストされたループやIF分岐のロジックの流れが把握できるなぁ！　と。
 超能力者か、あるいは天才か　という感想です。

 以下のほうがコードロジックの把握、しやすくないですか？

'ユーザー定義型
Type inDAT

    Name As String
    stTime As String
    Car As String
    To As String
    Root As String
    Tel As String
    edTime As String
End Type

Sub Main()
'メイン処理

    Dim dat() As inDAT    '入力データ
    Dim rg As Range    'シェイプ貼り付け範囲
    Dim endRow As Integer, endCol As Integer    'データの行列の終端
    Dim putRow As Integer, putcol(1) As Integer    'シェイプ貼り付け範囲（列方向）
    Dim i As Integer, j As Integer    'ループカウンタ
'入力データをユーザー定義型変数へ配列格納
    With ThisWorkbook.Sheets("データ入力シート")
        endRow = .Cells(Rows.Count, 1).End(xlUp).Row
        ReDim dat(1 To endRow - 1)
        j = 1
        For i = 2 To endRow
            dat(j).Name = .Cells(i, 1).Value
            dat(j).stTime = Format(.Cells(i, 2).Value, "hh:mm")
            dat(j).Car = .Cells(i, 3).Value
            dat(j).To = .Cells(i, 4).Value
            dat(j).Root = .Cells(i, 5).Value
            dat(j).Tel = .Cells(i, 6).Value
            dat(j).edTime = Format(.Cells(i, 7).Value, "hh:mm")
            j = j + 1
        Next i
    End With
    'シェイプ作成範囲を求める
    With ThisWorkbook.Sheets("SKDシート")
        .DrawingObjects.Delete
        endRow = .Cells(Rows.Count, 1).End(xlUp).Row
        endCol = .Cells(1, Columns.Count).End(xlToLeft).Column
        For i = 1 To UBound(dat)
            For j = 2 To endRow
                If .Cells(j, 1).Value = dat(i).Name Then
                    putRow = j
                    Exit For
                End If
            Next j
            For j = 2 To endCol
                If Format(.Cells(1, j).Value, "hh:mm") = dat(i).stTime Then
                    putcol(0) = j
                End If
                If Format(.Cells(1, j).Value, "hh:mm") = dat(i).edTime Then
                    putcol(1) = j
                    Exit For
                End If
            Next j
            Set rg = .Range(.Cells(putRow, putcol(0)), .Cells(putRow, putcol(1)))
            Call PUT_SHAPE(rg, dat(i))
        Next i
    End With
    Erase dat
    Set rg = Nothing
    Sheet2.Activate

End Sub

Private Sub PUT_SHAPE(rg As Range, txt As inDAT)
'シェイプ作成処理(貼り付け範囲,1件分のデータ)

    Dim spTxt As String
    Dim x As Integer
    x = 5    '調整値(シェイプの高さ調整 0で隙間がなくなる)
    'テキスト内容を作成
    spTxt = txt.Car & Space(2)
    spTxt = spTxt & txt.Root & Space(2)
    spTxt = spTxt & txt.To & vbCrLf
    spTxt = spTxt & txt.stTime & Space(2)
    spTxt = spTxt & txt.Tel & Space(2)
    spTxt = spTxt & txt.edTime
    'シェイプ作成
    With ThisWorkbook.Sheets("SKDシート").Shapes.AddShape _
         (msoShapeRectangle, rg.Left, rg.Top + x / 2, rg.Width, rg.Height - x).TextFrame
        .Characters.Text = spTxt
        .Characters.Font.Size = 10
        .HorizontalAlignment = xlHAlignCenter    ' 中央揃え
        .VerticalAlignment = xlVAlignCenter    ' 中央揃え
    End With
End Sub

（β） 2016/02/21(日) 23:30

 （γ） 2016/02/21(日) 23:21 で　γさんがコメントしておられることを、是非、検討していただきたいです。

 レイアウトも漠然としていますし、アップされたコードも、詳細をおいかけていませんが、想像するに

 ・入力シートに記載された情報から、SKDシートの四角形を洗い替え
 ・その後、SKDシートの四角形コメントが操作者によって変更される。
 ・あるタイミングで、そのすべての四角形のテキストを抽出し、【どこかのシート】（SKD午前　等？）のしかるべき位置に
 　そのテキストを転記。

 ということなんでしょうか？

 それであれば、

 ・元シート（入力シート？）にテキストを書きこむ
 ・そのChangeイベントで、『該当の四角形』のテキストを書き換える
 ・あわせて、しかるべきシート（午前SKD等？）のしかるべき位置のテキストを書き換える

 これを実現するためには、SKDシートに生成された各四角形に、【特定できる固有の名前】をつけておく。
 その名前がどういったものが適切なのかは、要件が不明なのでなんともいえませんが、要は入力シートのテキストの位置と
 １：１で紐付く名前。

 こうしておくとよろしいのではと思います。

（β） 2016/02/22(月) 08:31

 繰り返しになりますが

 >>1.2.3.行目で上記のような内容の四角形のデータを簡単に抜き出す事が出来れば何もこだわりはないのです。

 ご自身も認識しておられる通り、ある領域のシェープのみを抽出ということは（できればいいのですけど）できません。
 現在のコードでやっておられるように、すべてのシェープを抜出し、それが目的にセル領域にあるかどうかの判定が必要です。

 工夫の余地があると申し上げたのは、あらかじめ、すべてのシェープを取り出し、その位置情報をキーにしたテーブルに格納しておく。
 実際の処理では、そのテーブルを参照し、目的の位置にあるシェープのみを淡々と取り出すということです。

 しかしながら、それより、γさんが示唆された方式を是非検討いただきたいですね。

（β） 2016/02/22(月) 08:39

コメント返信：

[ 一覧(最新更新順) ]

[[20160219124019]] 『図形（正方形/長方形）の中の文字抽出』（オグ09） ページの最後に飛ぶ

[[20160219124019]]　『図形（正方形/長方形）の中の文字抽出』（オグ09）　ページの最後に飛ぶ