excel2007マクロで特定URLを抽出したい

質問

初めてお世話になります。
Excel2007のマクロについて質問です。

【元ファイル】

1行目：見出し１
2行目：http://yahoo.com/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp

1行目：見出し2
2行目：http://google.com/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp

1行目：見出し3
2行目：http://oshiete.com/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp

1行目：見出し4
2行目：http://yahoo.co.jp/oshiete/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp

1行目：見出し5
2行目：http://google.com/aaa/oshiete.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.com

上記のような形式の数十行のテキストファイル
(アウトルックのメール本文からメモ帳などに張り付けを想定)が素材です。

【ご質問】
上記のような2行ごとのテキストの中から「oshiete」を含むURLのみを
エクセルのG列、その直上の見出しをエクセルのF列に書き込んでいきたいのですが、
どのようなマクロを書けばよろしいでしょうか。

特徴としてはURL部分がかなり長いです。可変ですが、半角で130～140文字くらいあります。
途中切れなどがないようにしたいと考えております。

この作業は日次で繰り返し、excelファイルは1週間単位で新しいものを作成します。
可能であれば、B列あたりに　書き込み日時（yyyy/mm/dd）も持たせられれば最高です。。

excelの関数や操作などはそこそこ理解できるのですが、マクロは全くの初心者です。
詳しい方にご教示いただければ大変うれしく思います。
よろしくお願いいたします。

回答No.2

merlionXX · ベストアンサー

「すぐに回答ほしいです」になってる質問に、ほんとにすぐ回答しても、一週間も放置されたら、普通はそんな質問はもう見に行きませんよ。
だから、上手くいかなかったという書き込みも今やっと知りました。
余計なことを書きましたが、それはさておき、最後にSheet3が表示されるのは、それが最後のシートなんでしょ？そのシートの後に作業用のシートを挿入し、そこにテキストを読み込んで作業し、終了後にその最後シートを削除したから、残った最後のSheet3が現れたわけです。
コードの最後を

途中略
Application.DisplayAlerts = False
ws.Delete
Application.DisplayAlerts = True
Sheets("Sheet1").Activate
End Sub

にすれば防げますが、問題は書き込まれる先のSheet1が空白のままだということですね？

マクロを実行すると書き込むような動作が見えるとのことですので、TXTファイルからの読み込みはできているはずだと思います。そうなると、残る原因は、対象としたTXTファイルの中に"oshiete"という文言が入ってなかったことぐらいしか考えられません。
多分、質問の"oshiete"は仮の言葉で、本当は違う単語だと思いますが、その単語にVBAのコードを修正するとき、ミスタイプしてませんか？

お礼

できました！ありがとうございました。

確認したところ"oshiete"に該当する部分が、当方が不在の間に変更になっていました。
文言を書き換えたらできました。

おっしゃるとおりで、突然同僚の代わりに出張になってしまい、
お返事が遅れてしまいました。
大変申し訳ありませんでした。

本当に助かりました。ありがとうございました。

回答No.1

merlionXX

以下のような、拡張子.txtのテキストファイル（memo帳）から「oshiete」を含むURLのみを取り込む一例です。
取り込み先は、このマクロを記述したBOOKのSheet1です。

見出し１
http://yahoo.com/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp
見出し2
http://google.com/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp
見出し3
http://oshiete.com/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp
見出し4
http://yahoo.co.jp/oshiete/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.jp
見出し5
http://google.com/aaa/oshiete.aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa.com

Sub test01()
　　Dim myFn
　　Dim x As Long, i As Long
　　Dim myC As Range
　　Dim ws As Worksheet
　　myFn = Application.GetOpenFilename(FileFilter:="TXTファイル(*.txt),*.txt", Title:="TXTファイルを選択してください。")
　　If myFn = False Then
　　　　MsgBox "きゃんせる", , "Σ（￣ロ￣lll)　　"
　　　　End
　　End If
　　Set ws = Sheets.Add(After:=Sheets(Sheets.Count))
　　With ws.QueryTables.Add(Connection:="TEXT;" & myFn, Destination:=ws.Range("A1"))
　　　　.TextFileColumnDataTypes = Array(2)
　　　　.Refresh BackgroundQuery:=False
　　　　For Each myC In .ResultRange
　　　　If InStr(myC.Value, "oshiete") > 0 Then
　　　　　　i = i + 1
　　　　　　Sheets("Sheet1").Cells(i, "G").Value = myC.Value
　　　　　　Sheets("Sheet1").Cells(i, "F").Value = myC.Offset(-1).Value
　　　　　　Sheets("Sheet1").Cells(i, "B").Value = Format(Now, "yyyy/mm/dd hh:mm:ss")
　　　　End If
　　　　Next myC
　　End With
　　Application.DisplayAlerts = False
　　ws.Delete
　　Application.DisplayAlerts = True
End Sub

お礼

ありがとうございます！
お返事が遅くなってしまい、申し訳ありません。
こんなにすぐ回答いただけるなんてびっくりしました。

さて、エクセル2007でマクロを実行してみたのですが、うまく書き込みが
できませんでした。
sheet1の状態でマクロを実行するとURLを書き込むような動作が
走っているように見えるのですが、最後はsheet3を開いた状態で
終了してしまいます。シートは全て空白の状態です。
もしかしたら当方の設定か何かでしょうか。。