fc2ブログ

1日3タックルを目指して頑張ります。 ロリ巨乳が大好きです。 > 今日の3タックルTopへ

Top /  若干エンジニアらしい話 /  Excel /  Excel でテキストボックス内を検索だと!!!
« 翌日配送ってすごいサービスだと思う。  |  早出 »

Excel でテキストボックス内を検索だと!!!

 2012/09/29 (Sat) -  カテゴリ:  若干エンジニアらしい話 »  Excel

Excel のテキストボックス内の文字列を検索して、引っかかったテキストボックスの場所を探すようなことが必要になったので、がんばってみた。

面倒だったのは「テキストボックスがグループ化されているかもしれないということ」+「Shape の左上セルを返す TopLeftCell メソッドをグループ化したテキストボックスに使うと異常なセルを返してくること」の2点

せっかくコーディングしたので、とりあえずコードを貼っておく。アクティブシートに対して動くので試したい人は適当なシートにテキストボックスを追加して、B1セルに正規表現で検索条件を入れて TextBoxSearch を動かしてみてくださいな。結果は A4 のセルから下に出ます。正規表現の括弧の対応がおかしいとかそういうのはおそらくエラーになるでしょう。

Option Explicit

Public Sub TextBoxSearch()

    ' Microsoft VBScript Regular Expressions 5.5 を参照設定してね。
    Dim re As RegExp
    Set re = New RegExp

    If ActiveSheet.Range("B1") = "" Then
        MsgBox "B1のセルに検索条件を入れてください。(正規表現でマッチします)"
        Exit Sub
    End If
    re.Pattern = ActiveSheet.Range("B1")

    Dim shps As Collection
    Set shps = New Collection
    Dim targetText As String
    Dim shp As Shape
    Dim gi As Shape
    Dim resultCell As Range
    
    For Each shp In ActiveSheet.Shapes
        shps.Add shp
    Next shp
    
    ActiveSheet.Range("A4:B65536").ClearContents
    ActiveSheet.Range("A3").Value = "検索結果"
    
    Dim i As Long
    i = 1
    Do While True
        If shps.Count < i Then Exit Do
        Set shp = shps.Item(i)
        Select Case shp.Type
        Case msoTextBox
            ' テキストボックスのテキストだけ得る方法がわからんから無理やり AlternativeText
            ' から引き抜く
            targetText = Mid(shp.AlternativeText, Len("テキスト ボックス: ") + 1)
            If re.Test(targetText) Then
                'Debug.Print shp.TopLeftCell.Address グループ化されてるとおかしなことになるので使えない
                Set resultCell = ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0)
                resultCell.Value = targetText
                resultCell.Offset(0, 1).Value = TopLeftCell(shp).Address
                ' ハイパーリンクでも貼ってみる。
                ActiveSheet.Hyperlinks.Add Anchor:=resultCell.Offset(0, 1), Address:="", SubAddress:=ActiveSheet.Name & "!" & TopLeftCell(shp).Address
            End If
        Case msoGroup
            For Each gi In shp.GroupItems
                shps.Add gi
            Next gi
        End Select
        i = i + 1
    Loop
End Sub

Private Function TopLeftCell(shape_ As Shape) As Range
    ' グループ化すると TopLeftCell がおかしな値になるので
    ' 力技でセルの位置を特定
    Dim top As Double, left As Double
    Dim cs As Long, ce As Long, rs As Long, re As Long
    left = shape_.left
    top = shape_.top
    cs = 1
    ce = 256
    rs = 1
    re = 65536
    Do
        If ActiveSheet.Cells(1, (cs + ce) \ 2).left <= left Then
            cs = (cs + ce) \ 2
        Else
            ce = (cs + ce) \ 2
        End If
    Loop While (ce - cs) \ 2 > 0
    
    Do
        If ActiveSheet.Cells((rs + re) \ 2, 1).top <= top Then
            rs = (rs + re) \ 2
        Else
            re = (rs + re) \ 2
        End If
    Loop While (re - rs) \ 2 > 0

    Set TopLeftCell = ActiveSheet.Cells(rs, cs)
End Function

さすがは VBA だ。なんとなく書いてみれば動くもんだな。

SkyDriveにおいてみた Excel2000 で作ってるので、新しいので動くかは謎

« 翌日配送ってすごいサービスだと思う。  | トップへ |  早出 »

コメント

Comment Form
このエントリへコメントを書く
(任意)
(任意)
(任意)
(必須) HTML のタグは使用できません
(AAを貼るときは、[太字] ココにAAを書く [/太字] のように 太字 タグで括るときれいになります。左下の[太]ボタンをクリックして「ずれないAA 小」 というところにAAを書いてください。斜体、下線、打消 で括ってもずれないAAにすることができます。)
http:// は禁止ワードです。
(任意) ID生成と編集に使用します

コメントのプレビューのようなもの

ここにプレビューが出ます。

トップへ

トラックバック

http://3tackle.blog55.fc2.com/tb.php/1094-8540b346

最新記事
カテゴリ
最新コメント
最新トラックバック
月別アーカイブ
カウンタ
_
カレンダー
01 | 2024/02 | 03
- - - - 1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 - -
これはやべぇ

インターネッツの設定をしてあげたついでに、接続確認と称してこのブログを開いたら、気になるあの娘が検索したアイテムがwww

万が一アダルトグッズが表示されたりしたらと思うと股間が熱くなるな。

とか妄想してたけど、インターネッツの設定をしてあげた直後に検索の履歴が残ってるわけないか
(´・ω・`)
にしても使い方によってはこの機能は凶悪だな。

プロフィール

タックル

Author:タックル
三度のメシより大ライスが好きなエンジニアです。
焼肉屋に行ったら最初の一杯は大ライスで乾杯! 全然関係ないけど食堂のカレーなら4杯は軽いよ。

ちなみにロリ巨乳は大ライスより好き!

プライベートでタックルされてくれるロリ巨乳のお友達を24時間365日募集中です。

エントリーの内容はタックルの日々の生活について多少脚色しながら面白おかしく書いている限りなくノンフィクションに近いフィクションです。

嘘を嘘と見抜けない人は(ry

Webサービス
フィードメーター - 今日の3タックル あわせて読みたいブログパーツ
タックル会
個人的なリンク