【Excel】ある文字列からはじまる文を抽出したいのです。

お世話になっています。

むちゃくちゃな羅列のテキストがあるのですが、その中にいくつかhttp://～で始まる文があります。

それだけを抽出して別シートに一覧表示したいのですが、どうしたらできますか？
マクロで可能だと思いますが、アフォなのでよくわかりません。(>_<)

No.6 ベストアンサー 回答者： Wendy02 回答日時： 2005/07/21 14:58

Wendy02 です。

最後のコードは、以下のように直してください。
たぶん、それでよいはずです。

'別シートのA1から下に出力
Worksheets("Sheet2").Range("A1").Resize(u) = Application.Transpose(myArray)

この回答へのお礼

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

OKが重くてお礼が遅れました。
5さんのより思っていた結果が出ました。

すごいです。

お礼日時：2005/07/22 10:09

No.5 回答者： KenKen_SP 回答日時： 2005/07/21 14:32

こんにちは。

KenKen_SP です。

試しにコードを書いていたら、Wendy02 さんに先を越されました(^^)
似たようなコードですが、折角書いたので（←自分勝手）アップさせて下さい。

Sub URL抽出()

　　Dim RegEx　　　As Object
　　Dim strPattern As String
　　Dim objMatches As Object
　　Dim objItem　　As Object
　　Dim rngCell　　As Range
　　Dim Source　　 As String
　　Dim lngCounter As Long
　　Dim Buf()　　　As String
　　
　　'URLパターン
　　strPattern = "((http|https|ftp)://[-_.!~*'()a-zA-Z0-9;/?:@&=+$,]+)"
　　'マッチング
　　lngCounter = 0
　　Set RegEx = CreateObject("VBScript.RegExp")
　　With RegEx
　　　　.Pattern = strPattern
　　　　.Global = True
　　　　For Each rngCell In Selection
　　　　　　If Not IsEmpty(rngCell) Then
　　　　　　　　Source = StrConv(Trim$(rngCell.Text), vbNarrow Or vbLowerCase)
　　　　　　　　Set objMatches = .Execute(Source)
　　　　　　　　For Each objItem In objMatches
　　　　　　　　　　ReDim Preserve Buf(lngCounter)
　　　　　　　　　　Buf(lngCounter) = objItem
　　　　　　　　　　lngCounter = lngCounter + 1
　　　　　　　　Next objItem
　　　　　　　　Set objMatches = Nothing
　　　　　　End If
　　　　Next rngCell
　　End With
　　Set RegEx = Nothing
　　'結果出力
　　With ActiveWorkbook.Sheets.Add
　　　　.Range("A1").Resize(UBound(Buf) + 1).Value = _
　　　　Application.Transpose(Buf)
　　End With

End Sub

この回答へのお礼

できました。
思ってたとおりの処理になりました。

どうもありがとうございました。

いや～、賢いですね～

お礼日時：2005/07/21 16:04

No.4 回答者： Wendy02 回答日時： 2005/07/21 12:51

こんにちは。

＞むちゃくちゃな羅列のテキストがあるのですが、その中にいくつかhttp://～で始まる文があります。

マクロを希望されているので、設定等は細かく書きません。範囲をマクロで選択してからお使いください。むちゃくちゃな羅列のテキストというのは、どういうものか分かりませんから、URL の末尾の文字の判定をどうするか、少し、不安な部分があります。

現在、別シートというのを、「Sheet2」に設定してありますので、任意で変更してください。



'<標準モジュール>
Sub PickupURL()
　 Dim objRE As Object
　 Dim Match As Object, Matches As Object
　 Dim Rng As Range
　 Dim c As Range, i As Long, u As Long
　 Dim myArray() As Variant
　 Set Rng = Selection
　 Set objRE = CreateObject("VBScript.RegExp")
　 With objRE
　　　.Pattern = "(http://\S+)"
　　　.Global = True
　 For Each c In Rng
　 Set Matches = .Execute(c.Text)
　　　For Each Match In Matches
　　　ReDim Preserve myArray(i)
　　　　 myArray(i) = .Replace(Match, "$1")
　　　i = i + 1
　　　Next
　 Next
　 End With
　 If i = 0 Then Exit Sub
　 u = UBound(myArray) - LBound(myArray) + 1
　 '別シートのA1から下に出力
　 Worksheets("Sheet2").Range("A1").Resize(u) = myArray
　 Set objRE = Nothing
End Sub

この回答への補足

ご回答ありがとうございました。

さっそく試してみましたが、最初に見つけたURLは抽出してくれたのですが、
その同じURLが複数リスト化されました。

どうも思っていた動きと違うみたいです。
修正しようにも自分には技量不足みたいです。。。
プログラムが組めてうらやましいです。

とても参考になりました。
本当にありがとうございました。

補足日時：2005/07/21 14:21

No.3 回答者： xyz37005 回答日時： 2005/07/21 12:47

質問文でよくわからない点もあるんですが、探してきました。

検索したい文字列を入力すると、Sheet1のＡ列を検索して
該当するデータをSheet2に抽出するマクロ
http://park11.wakwak.com/~miko/Excel_Note/16-01_ …
ただこれでURL部分のみを抜き出したい場合、URLのみで構成される単独行でないとできません。

なんか質問文を見ると“あるテキストからURLのみを抜き出したい。”というのが目的で
EXCELでやるという必要性がうかがえないのですが。
もしEXCELでなくてもよいなら秀丸マクロを使う方法もあります。
http://hide.maruo.co.jp/lib/macro/listup101.html
こちらはやり方にも寄りますが、URL部分のみを抜き出せます。

この回答への補足

>EXCELでやるという必要性がうかがえないのですが。

おっしゃるとおりです。(´・ω・｀)
秀丸マクロとやらを試してみます。

補足日時：2005/07/21 14:19

No.2 回答者： moon_myu 回答日時： 2005/07/21 12:28

オートフィルタ、フィルタオプションを使って抽出したデータを別シートに、コピー→貼付　という手は？

むちゃくちゃな羅列のテキストが、同一列に書かれている。。が必要ですけど、使用方法はヘルプで調べてみて～　どう書いて良いのか判りません。<^!^>ごめんね。

この回答へのお礼

ご回答どうもありがとうございました。

お礼日時：2005/07/21 14:34

No.1 回答者： shiotan99 回答日時： 2005/07/21 10:53

こんにちは～

そのテキストは特定の列にあるんでしょうか？

そうだとして、作業列を使ってもよいなら以下の方法で。

テキストがSheet1のA列1行目からあり、作業列をB列とすれば、
B1に、

=IF(LEFT(A1,7)="http://",ROW(),"")

を入れ、下にフィルコピー

別シートのどのセルでもいいので、

=IF(COUNT(Sheet1!B:B)<ROW(A1),"",INDEX(Sheet1!A:A,SMALL(Sheet1!B:B,ROW(A1))))

を入れ、必要分、下にフィルコピー

この回答へのお礼

ご回答ありがとうございました。

お礼日時：2005/07/22 10:10