[[20050119194834]]　『テキストボックス内の文字をセルに』（みなみ）　ページの最後に飛ぶ

『テキストボックス内の文字をセルに』（みなみ）

 VBA未経験の者です。
グラフエリア内の複数のテキストボックスに書いてある文字を
セルに抽出したいのですが、何か方法はありますでしょうか。

 Excelは2000を使用しております。
どうぞよろしくお願い致します。

 こんな感じでいけますでしょうか。
Sub Test()
Dim MyText As Shape
Dim MyTextName As String
Dim i As Long
Application.ScreenUpdating = False
MyRange = ActiveCell.Address
Set MySh = Worksheets("Sheet1")
    MySh.ChartObjects("グラフ 1").Activate
    For Each MyText In ActiveChart.Shapes
        MyTextName = MyText.DrawingObject.Caption
        MySh.Cells(1 + i, 5).Value = MyTextName
        i = i + 1
    Next MyText
Range(MyRange).Activate
Application.ScreenUpdating = True
End Sub

 （川野鮎太郎）

 お返事ありがとうございます。
抽出はできたのですが、
テキストボックスの順番とセルに抽出された順番がバラバラになってしまいます。
グラフエリア内はスポーツ大会の組み合わせ表のようになっており、
テキストボックスは同じ位置に並んでいます。
表示上と同じ順番で抽出したいのですがどうすればよいでしょうか。
よろしくお願い致します。
（みなみ）

 縦に並んでいますか、横に並んでいますか？
 また、抽出先のセルはどこがご希望でしょうか。
 （川野鮎太郎）

 説明不足で申し訳ありません。
テキストボックスは横に並んでおります。
抽出先はAB27,AC27 ･･･ という具合に抽出できますでしょうか。
何度も申し訳ありませんがよろしくお願い致します。
（みなみ）

 これでいけますでしょうか。
 並び替えるのに、AJ27からAQ28を使っています。
　
Sub Test()
Dim MyText As Shape
Dim MyTextName As String
Dim i As Long
Const MyR As Long = 27, MyC As Long = 28  '抽出先の行列
Application.ScreenUpdating = False
Set MySh = Worksheets("Sheet1")
    MySh.ChartObjects("グラフ 1").Activate
    For Each MyText In ActiveChart.Shapes
        MyTextName = MyText.DrawingObject.Caption
        With MySh.Cells(MyR, MyC + i)
            .Value = MyTextName
            .Offset(1, 0).Value = MyText.Left
            i = i + 1
        End With
    Next MyText
    Range("A1").Activate
    Range(Cells(MyR, MyC), Cells(MyR + 1, MyC + 15)).Sort _
            Key1:=Range("AB28"), Orientation:=xlLeftToRight
        With Cells(MyR, MyC + 8)
            Cells(MyR, MyC).Offset(1, 0).Resize(1, 8).Value = .Resize(1, 8).Value
            .Resize(2, 8).ClearContents
        End With
    Application.ScreenUpdating = True
End Sub

 （川野鮎太郎）

 MyTextName = MyText.DrawingObject.Caption
の部分が

 エラー'438'
オブジェクトはこのプロパティまたは
メソッドをサポートしていません

 といわれて止まってしまいます。
どうすればエラーが出なくなるか教えていただけませんでしょうか。
毎回デバッグ画面にいってしまい困っております。
よろしくお願い致します。
 （みなみ）

 あれれ？？？一度は抽出できたんですよね・・・？う～ん(/-_-＼)

 これかな・・・？
エクセルのヘルプより。
隠しオブジェクト
　
Excel 97 版の Visual Basic オブジェクト モデルでの隠しオブジェクトを示します。
これらのオブジェクトは、以前のバージョンとの互換性を保持するためにあります。
新しいコードの場合、Excel 97 で用意されている新機能を使用する必要があります。
[オブジェクト ブラウザ] ウィンドウで隠しオブジェクトを表示するには、
[オブジェクト ブラウザ] ウィンドウでマウスの右ボタンをクリックし、
ショートカット メニューの [非表示のメンバーを表示] をクリックします。

 一度お試しになりますか？

 （川野鮎太郎）

 言葉不足で申し訳ありません。
今まで毎回エラーでデバッグ画面に飛んでおり、デバッグするとデータが抽出されていました。
また、これは関係があるか解らないのですが、
抽出データは二行にわたっており、上段が文字、下段に数値が抽出されていました。
テキストボックス内に数値は見当たらないのでどこから出てきた値なのかわかりません。
シート内を検索してみましたが該当に数値は見当たりませんでした。
当初、("Sheet1")の部分を書き換えていたのでその為のエラーだと思っていたのですが、
そうでは無いようなので再度質問させていただきました。
お忙しいところ恐縮ですが、よろしくお願い致します。
 （みなみ）

 いっそのこと以下に変えてみてください。
Sub Test()
Dim MySh As Worksheet
Dim MyText As Shape
Dim MyTextName As String
Dim i As Long, StCnt As Long
Const MyR As Long = 27, MyC As Long = 28  '抽出先の行列
Application.ScreenUpdating = False
Set MySh = Worksheets("Sheet1")
    MySh.ChartObjects("グラフ 1").Activate
    For Each MyText In ActiveChart.Shapes
        MyTextName = MyText.AlternativeText
        StCnt = Application.Find(":", MyTextName, 1)
        MyTextName = Mid(MyTextName, StCnt + 2, 1)
        With MySh.Cells(MyR, MyC + i)
            .Value = MyTextName
            .Offset(1, 0).Value = MyText.Left
            i = i + 1
        End With
    Next MyText
    Range("A1").Activate
    Range(Cells(MyR, MyC), Cells(MyR + 1, MyC + 15)).Sort _
            Key1:=Range("AB28"), Orientation:=xlLeftToRight
        With Cells(MyR, MyC + 8)
            Cells(MyR, MyC).Offset(1, 0).Resize(1, 8).Value = .Resize(1, 8).Value
            .Resize(2, 8).ClearContents
        End With
    Application.ScreenUpdating = True
End Sub

 （川野鮎太郎）

 お返事が遅くなって申し訳ありません。
やはりエラーで止まってしまい、デバッグ画面にいってしまいます。
ひっかかっているのは
MyTextName = MyText.AlternativeText
の部分のようなのですが、Excel2000を使用しているのが悪いのでしょうか？
 （みなみ）

 そのデバッグになっているときに、VBEの画面の表示－ローカルウインドウを出して
 MyTextの　+　マークを開いて、"テキストボックス ***"　となっているプロパティは
 ありませんか？
 ***は、テキストボックスの中身の文字です。

 ツールの参照設定で何かを有効にしないと出ないのかな・・・。？
 私もExcel2000なんですけどね・・。

 （川野鮎太郎）

 横からお邪魔します。
先ほど、川野鮎太郎さんのマクロを試してみましたが問題なく動きましたよ。
テキストボックスに何も書いてないテキストボックスがあるんじゃないんですか？
テキストボックスがあっても空白だったらパスするようなコードを追加すれば
いいんじゃないんですか？
（SoulMan）

 う～ん(/-_-＼)
 空白だったらその下の　StCnt = Application.Find(":", MyTextName, 1)　で
 エラーになるはずなのよね・・・＿/￣|○ il||li

 （川野鮎太郎）

 そうなんだけど、最初に試した時そこで止まったから、、、
テキストボックスに何か適当にかいたら、後は全然止まらなかったよ。
（SoulMan）

 へえぇぇ、そんなこともあるんだ(^_^A;
 忙しいのに検証ありがとう＾＾ｖ
 ところで・・・・、○○試験はどうだったんだろ・・・。
 （川野鮎太郎）

 ちょっと試しに作ってみました。
どうでしょう？
Option Explicit
Sub てすと()
Dim MyStr As String, MyAry() As Variant
Dim i As Long, k As Long
    With Worksheets("Sheet1")
        With .ChartObjects(1).Chart
            For k = 1 To .Shapes.Count
                MyStr = Replace(.Shapes(k).AlternativeText, "テキスト ボックス:", "")
                If MyStr <> "" Then
                    i = i + 1
                    If i > 229 Then Exit For
                    ReDim Preserve MyAry(1 To i)
                    MyAry(i) = MyStr
                End If
            Next
        End With
        .Range("AB27", .Range("AB27").End(xlToRight)).ClearContents
        If i > 0 Then
            With .Range("AB27")
                .Resize(, i).Value = MyAry
                .Resize(, i).EntireColumn.AutoFit
            End With
        End If
    End With
Erase MyAry
End Sub
失礼！テキストボックスがなかったら、エラーになるのでちょっと訂正m(._.)m ペコッ
http://ryusendo.no-ip.com/cgi-bin/upload/src/up0227.xls
度々すみません。↓は
Dim MyShape As Shape
不要でした。m(._.)m ペコッ×3
（SoulMan）

コメント返信：

[ 一覧(最新更新順) ]

[[20050119194834]] 『テキストボックス内の文字をセルに』（みなみ） ページの最後に飛ぶ

[[20050119194834]]　『テキストボックス内の文字をセルに』（みなみ）　ページの最後に飛ぶ