データを任意の文字で検索

Question

はじめまして。
4000行程度あるデータを任意の文字で検索したいと考えています。
検索して、見つかった行を選択し、コピーしたいのですが、作成したプログラムだと最後のところでエラー表示されます。コピーするプログラムはまだ作成していません。

検索結果が少なければ問題なく動くのですが、行数が増えると最後のJoinのところで「Rangeメソッドは失敗しました。Globalオブジェクト」と表示されてしまいます。

どうすれば解決するのか見当がつかないため、教えていただければ大変助かります。
初心者のため、おかしなプログラムを作成していたらご指摘いただければと思います。
よろしくお願いいたします。


Private Sub botan1_Click()

Dim Str As String
Dim ArrayStr() As String
Dim word As Variant
Dim rng As Range
Dim FoundAddr() As String

t = Box1
Str = Replace(t, "　", " ")
ReDim Preserve ArrayStr(4)
ArrayStr() = Split(Str, " ")

For Each word In ArrayStr
Set rng = Cells.Find(word, LookAt:=xlPart)
If rng Is Nothing Then Exit Sub
p = rng.Address

Range(p).Select
 
 Do
        ReDim Preserve FoundAddr(i)
        o = rng.Row & ":" & rng.Row

        FoundAddr(i) = o
        Set rng = Cells.FindNext(After:=rng)
        i = i + 1
        If rng Is Nothing Then Exit Do
    Loop Until rng.Address = p

Next

    Range(Join(FoundAddr(), ",")).Select
End Sub

WindFaller · Accepted Answer

こんにちは。

今、ちょっと調べてみましたら、前回の同様の質問は削除されたのですね。
前回のコードは作ってあったので、それを手直しすることにしました。
しかし、基本的に直さないといけないものがあり、後々、ずっと尾を引くことがあるので、面白くなくても、我慢して聞いてください。これは、ご質問者さんが遠くない将来に、人にコードを教える時のためです。

1.　「botan1」日本人だからいいじゃないの、と言っても、一応、綴りは調べてください。
Button です。ちなみに、「在庫」は、ローマ字でZaiko と書いてもよいのですが、できるなら、日本人で分かるレベルの英語を使います。「在庫」は"Inventory" や"Stock"とします。
これは、コーディングルールという中に出てきます。

2. Strは、VB関数ですから、そのものずばりを使うのは避けましょう。ただしVB.Net では、Okです。wordは、別に予約語ではありませんが、wordオブジェクトと紛らわしいので、wd とするなり、そのものずばりは辞めたほうが、後々、エラーなどのトラブルにならなくて済みます。

3. 私は、"Option Explicit" を強制するようなことは言いませんが、突然現れる変数ともオブジェクトとも分からないものは、最初に説明を入れてください。t = Box1　ここでエラーが発生します。たぶん、ActiveX コントロールのTextBox1 だと解釈しました。

私自身は、Active Xコントロールの生成された名前は、あまりいじることはしません。目的別で名前をつけると、後々、種類が分かりにくくなるからです。むろん、プリフィックス文字(bx,cm,bt など）を使えばということもありますが、プライベートユースでは、その必要性をことさら感じません。

また、t,p,o,i　の変数としては理解できますが、変数の宣言には加えておいたほうがよいです。
途中で加筆する時は、必要になる手前で、Dim i などとしても、今は良いとしています。

他は、テクニック上の問題ですから、あまり大きな問題ではありません。

一応、配列の中の文字をループで繰り返しで、一度確保した中で、ダブリを見つけなければ、"OR"検索です。"AND"検索にはなりません。ダブリを見つけるのは、Intersect メソッドですが、今回は使いませんでした。今回は、また、全角も半角も同じようにヒットし、Unionを使っているために、30行以上はコピーしません。本来、Unionが必要かどうかには、多少疑問が残ります。私のコードのように、一回で終わるなら、その都度、コピーしていっても良いはずです。

私のコードで、一応、ご質問内容も網羅されていると思います。

>検索したい文字が複数あるので、(例:太陽 晴れの両方を含むなど)
私のコードは、あくまでも、"AND"検索です。コードをみれば、考え方は分かってもらえると思います。

>どうすれば解決するのか見当がつかないため、

ご質問者さんは、初心者のレベルのコードではありませんが、初心者のみならず、この目的のマクロは、なかなかむつかしいレベルに入ります。私が書いたものが正解とは言いませんが、ループを繰り返して、Unionで確保していっても、かなり間延びしてしまわないかと考えました。

これが実務でしたら、オートフィルタで、範囲のHidden =False のセルを拾うほうが簡単だと思います。失礼な言葉がありましたら、予めお詫びしておきます。

'//
Private Sub Button2R_Click()
　Dim sTxt As String
　Dim arTxt As Variant
　Dim i As Long, j As Long, k As Long, l As Long
　Dim flg As Boolean
　Dim c As Range
　Dim n As Variant
　Dim FindCell() As Range
　Dim FirstAdd As String
　Dim myCells As Range
　Const LimitUNION As Integer = 30
　'ActiveSheet.Cells.Interior.ColorIndex = xlColorIndexNone　'色付けを消す
　
　'[Box1] を、Sheet1 のActiveX ControlのTextBox にする
　If Sheet1.Box1.Value = "" Then Exit Sub
　sTxt = Sheet1.Box1.Value
　Do
　　sTxt = Replace(sTxt, Space(2), Space(1), , , vbTextCompare)
　　sTxt = Replace(sTxt, Space(1), Space(1), , , vbTextCompare)
　Loop Until InStr(1, sTxt, Space(2), vbBinaryCompare) = 0 '空白値は1byte
　arTxt = Split(sTxt, Space(1))
　
　Set c = ActiveSheet.Cells.Find( _
　What:=arTxt(0), _
　LookIn:=xlValues, _
　LookAt:=xlPart, _
　SearchOrder:=xlByRows, _
　MatchByte:=False)
　If Not c Is Nothing Then
　　FirstAdd = c.Address '最初の検索値
　　If c.HasFormula = False _
　　And IsSecondWords(c, arTxt) Then '数式は除き,ユーザー定義関数判定
　　　ReDim Preserve FindCell(j)
　　　Set FindCell(j) = c
　　　j = j + 1
　　End If
　　Do
　　　Set c = ActiveSheet.Cells.FindNext(c)
　　　If c Is Nothing Then Exit Do
　　　If c.Address = FirstAdd Then Exit Do
　　　If c.HasFormula = False And _
　　　　IsSecondWords(c, arTxt) Then　'数式は除き、ユーザー定義関数判定
　　　　ReDim Preserve FindCell(j)
　　　　Set FindCell(j) = c
　　　　j = j + 1
　　　End If
　　Loop
　End If
　
　If UBound(FindCell()) > -1 Then
　If UBound(FindCell) >= 29 Then
　　　MsgBox "現行のコードでは、30行以上はコピーしません。", 48
　 End If
　　For Each n In FindCell
　　　If myCells Is Nothing Then
　　　 Set myCells = n
　　　 l = 1
　　　Else
　　　 Set myCells = Union(myCells, n)
　　　 l = l + 1
　　　End If
　　　If l >= 30 Then Exit For
　　Next
　 ' myCells.Interior.ColorIndex = 3　'色付け
　　Call arRangeCopy(myCells, Sheet3.Range("A1"))
　　myCells.Select
　 Else
　　 MsgBox "見つかりませんでした。", vbExclamation
　 End If
End Sub
Function IsSecondWords(c As Range, TxtArray As Variant) As Boolean
　'二重・三重検索
　Dim flg As Boolean
　Dim i As Long
　flg = False '気休め
　If UBound(TxtArray) > 0 Then
　　For i = 1 To UBound(TxtArray)
　　　If InStr(1, c.Text, TxtArray(i), vbTextCompare) = 0 Then
　　　　flg = False
　　　　Exit For
　　　Else
　　　　flg = True
　　　End If
　　Next i
　Else
　　flg = True
　End If
　IsSecondWords = flg
End Function
Sub arRangeCopy(srcRng, dstRng)
'コピー　srcRng ソース, dstRng　相手先
Dim c As Range
Dim r As Range
Dim rw As Long
Set r = dstRng.Cells(1)
　For Each c In srcRng.Areas
　　 c.Copy r.Offset(rw)
　　 rw = rw + 1
　Next c
End Sub
'//

bonaron · Answer

> セル番号を配列に格納して最後にunionで結合しようと思ったのですが、うまくいきません。

どんなコードで結合しようとして
どのようにうまくいかなかったのか、
エラーならそのメッセージなど、
詳細が抜けているのでコメントしようがありませんが。

ヘルプで「Application.Union メソッド」をご確認ください。
・引数は Range オブジェクト。
・第１、第２ 引数は必須。
・最大、３０の引数。
これらを満たしていますか？

bonaron · Answer

こちらが参考になるでしょう。

複数のセルを選択する
http://officetanaka.net/excel/vba/tips/tips126.htm

ShowMeHow · Answer

プログラム読むのもめんどくさいので、憶測だけど、、、
instr関数使うと楽なんじゃないかな？

データを任意の文字で検索

こんにちは。

> セル番号を配列に格納して最後にunionで結合しようと思ったのですが、うまくいきません。

こちらが参考になるでしょう。

プログラム読むのもめんどくさいので、憶測だけど、、、

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング