人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルVBAについて質問です。

特定のフォルダ内にある全てのファイルにおいて、
特定のキーワードに挟まれた文章を抽出するマクロを作ってください。


特定のフォルダ内における全てのファイルに記述される
「質問1」と「以上」の間の文章をA列に、
「質問2」と「以上」の間の文章をB列に
「質問3」と「以上」の間の文章をC列に記入する。

例えば、あるファイルに「質問1ももんがは飛ぶ?以上」とあった場合、
A1に「ももんがは飛ぶ?」を記入するというものです。

ただし、この作業は指定したフォルダの中にある
サブフォルダ内の全てのファイルに実行されることと、
同一ファイル内に記述される文章は同じ行に記述されるようにしてください。
つまり「a.txt」の「質問1?以上」はA1に、「質問2?以上」はB1に、
「b.html」の「質問1?以上」はA2に、「質問2?以上」はB2に記述すると言うことです。

説明が複雑になってすみません。ご不明な点はコメントください。
以上、よろしくお願いします。


●質問者: taroemon
●カテゴリ:コンピュータ
✍キーワード:A1 b2 HTML txt VBA
○ 状態 :終了
└ 回答数 : 2/2件

▽最新の回答へ

1 ● SALINGER
●200ポイント

とりあえず作ってみました。

質問の数は1個しか検索してません。(コードがさらに長くなってしまうので)

myMacro1()というやつを実行してください。

Private FSO
Private r As Long

Sub myMacro1()
  'フォルダのパスを指定してください
 Const FoldPath As String = "C:\Documents and Settings\hogehoge\デスクトップ\test"
 
 r = 1
 Set FSO = CreateObject("Scripting.FileSystemObject")
 
 Call myMacro2(FoldPath)
 
 Set FSO = Nothing
End Sub

Sub myMacro2(FoldPath As String)
 Dim myFile
 Dim myFold
 For Each myFile In FSO.GetFolder(FoldPath).Files
 Call myMacro3(myFile.Path)
 Next

 For Each myFold In FSO.GetFolder(FoldPath).SubFolders
 Call myMacro2(myFold.Path)
 Next
End Sub

Sub myMacro3(FilePath As String)
 Dim s As String
 Dim lngStart As Long
 Dim lngEnd As Long
 
 With FSO.OpenTextFile(FilePath)
 s = .ReadAll
 .Close
 End With
 
 lngStart = InStr(1, s, "質問1")
 If lngStart > 0 Then
 lngEnd = InStr(lngStart, s, "以上")
 If lngEnd > 0 Then
 Cells(r, 1).Value = Mid(s, lngStart, lngEnd - lngStart + 2)
 End If
 End If

 lngStart = InStr(1, s, "質問2")
 If lngStart > 0 Then
 lngEnd = InStr(lngStart, s, "以上")
 If lngEnd > 0 Then
 Cells(r, 2).Value = Mid(s, lngStart, lngEnd - lngStart + 2)
 End If
 End If
 
 lngStart = InStr(1, s, "質問3")
 If lngStart > 0 Then
 lngEnd = InStr(lngStart, s, "以上")
 If lngEnd > 0 Then
 Cells(r, 3).Value = Mid(s, lngStart, lngEnd - lngStart + 2)
 End If
 End If

 r = r + 1
End Sub

動作は確認してますが、エラートラップしてないので空のファイルがあるとエラーになります。

◎質問者からの返答

SALINGERさん。いつもありがとうございます。


ほとんど完璧にできていますが、

もしお時間があれば、いくつか手直していただけるとうれしいです。


?「質問1」と「以上」の間にある文字だけを抽出したいです。

たとえば「質問1ももんがとんだ。以上」を実行した場合、

「質問1」と「以上」も抽出されてしまいます。

「ももんがとんだ」だけが抽出されるようにしてください。


?「質問1」と「以上」の間に挟まれてる文字が無い場合、

書き込みはしないということにしてください。

「質問1以上」という文章を発見しても無視するということです。


?空のファイルは無視するとしてください。


?質問が複数ある場合も対処されているとうれしいです。


お願いすることが多いので申し訳ありません。


他の方からのご回答もお待ちしています。


2 ● SALINGER
●100ポイント

myMacro3()を変更して???は修正しました。HTMLタグについては他の人にまかせます。

Sub myMacro3(FilePath As String)
 Dim s As String
 Dim lngStart As Long
 Dim lngEnd As Long
 Dim TextFile
 Dim bl As Boolean
 Dim l1, l2, l3 As Long
 
 bl = False
 l1 = 1
 l2 = 1
 l3 = 1
 
 Set TextFile = FSO.OpenTextFile(FilePath)
 If Not TextFile.AtEndOfStream Then
 s = TextFile.readall
 
 While Not bl
 lngStart = InStr(l1, s, "質問1")
 If lngStart > 0 Then
 lngEnd = InStr(lngStart, s, "以上")
 If lngEnd > 0 Then
 Cells(r, 1).Value = Mid(s, lngStart + 3, lngEnd - lngStart - 3)
 bl = True
 l1 = lngEnd
 End If
 End If
 
 lngStart = InStr(l2, s, "質問2")
 If lngStart > 0 Then
 lngEnd = InStr(lngStart, s, "以上")
 If lngEnd > 0 Then
 Cells(r, 2).Value = Mid(s, lngStart + 3, lngEnd - lngStart - 3)
 bl = True
 l2 = lngEnd
 End If
 End If
 
 lngStart = InStr(l3, s, "質問3")
 If lngStart > 0 Then
 lngEnd = InStr(lngStart, s, "以上")
 If lngEnd > 0 Then
 Cells(r, 3).Value = Mid(s, lngStart + 3, lngEnd - lngStart - 3)
 bl = True
 l3 = lngEnd
 End If
 End If
 
 If bl Then
 r = r + 1
 bl = False
 Else
 bl = True
 End If
 Wend
 End If
 TextFile.Close
 Set TextFile = Nothing
End Sub
◎質問者からの返答

再度のご回答ありがとうございます。

とても助かりました。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ