全てのシートから特定文字を含むセルを抽出

全シート内にバラバラに「6241・・・・」（・・・・）は任意の数という8ケタの数字があります。
この8ケタの数字を別シート内に全て抽出し、並べたいのですがどうにもうまくいきません。
何かよい方法ありますでしょうか？

No.2 ベストアンサー 回答者： tom04 回答日時： 2015/09/18 11:50

NO.１です。

投稿後気づきました。

「6421」から始まるのではなく、「6241」ですね！
どうも失礼しました。

お判りでしょうが、前回のコードの
＞・・・"6421????",・・・
の部分を
＞・・・"6241????",・・・
に訂正してください。

どうも失礼しました。m(_ _)m

No.1 回答者： tom04 回答日時： 2015/09/18 11:43

こんにちは！

VBAになりますが、一例です。

＞別シート
とはSheet1（Sheet見出しの一番左側Sheet）とし、
＞全シート
とはSheet見出しの２番目以降にあるSheetすべてとします。
Sheet1（別Sheet）のA列１行目から羅列するようにしてみました。

Alt＋F11キー　→　メニュー　→　挿入　→　標準モジュール　→　VBE画面のカーソルが点滅しているところに
↓のコードをコピー＆ペースト　→　Excel画面に戻り（VBE画面を閉じて）マクロを実行してみてください。
（Alt＋F8キー　→　マクロ　→　マクロ実行です）

Sub Sample1() 'この行から//
Dim k As Long, cnt As Long
Dim str As String, wS As Worksheet
Dim myFirst As Range, myFound As Range

Set wS = Worksheets(1)
wS.Range("A:A").ClearContents
For k = 2 To Worksheets.Count
With Worksheets(k)
str = ""
Set myFound = .Cells.Find(what:="6421????", LookIn:=xlValues, lookat:=xlWhole)
If Not myFound Is Nothing Then
Set myFirst = myFound
str = myFirst.Address
cnt = cnt + 1
wS.Cells(cnt, "A") = myFound
Do
Set myFound = .Cells.FindNext(after:=myFound)
If myFound.Address = str Then Exit Do
cnt = cnt + 1
wS.Cells(cnt, "A") = myFound
Loop
End If
End With
Next k
End Sub 'この行まで//

※　各シートの6421から始まる８文字データが表示されると思います。
「6421ABCD」のような文字列も表示されてしまいます。。

まずはこの程度で・・・m(_ _)m