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


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


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

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

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

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

回答の条件
  • 1人2回まで
  • 登録:2007/12/29 18:33:25
  • 終了:2007/12/30 00:32:21

回答(2件)

id:SALINGER No.1

SALINGER回答回数3454ベストアンサー獲得回数9692007/12/29 20:17:00

ポイント200pt

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

質問の数は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

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

id:taroemon

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


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

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


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

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

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

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


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

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

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


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


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


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


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

2007/12/29 21:50:54
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692007/12/29 23:00:01

ポイント100pt

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
id:taroemon

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

とても助かりました。

2007/12/29 23:56:46
  • id:SALINGER
    ファイルはテキストファイルということでいいのでしょうか?
    ワードなどのバイナリファイルもあるのでしょうか。
    それと、一つのファイルに例えば、質問1~は2つは無いのでしょうか?
    ある場合は、セルにどのように表示しますか?
  • id:taroemon
    いつも本当にありがとうございます。

    >ファイルはテキストファイルということでいいのでしょうか?
    基本的にはテキストファイルかhtmlファイルです。
    両方対応していただけるとうれしいですが、
    難しいようでしたらテキストファイルだけでも結構です。

    >ワードなどのバイナリファイルもあるのでしょうか。
    ワードは考えていません。

    >一つのファイルに例えば、質問1~は2つは無いのでしょうか?
    >ある場合は、セルにどのように表示しますか?
    基本的にはありませんが、もし複数あるようでしたら、
    そのまま下の行に書き出していくという形にしてください。

    以上、よろしくお願いします。
  • id:taknt
    HTMLの場合は、タグがありますからねぇ。
    考慮は 難しいです。

    >「質問1」と「以上」の間の文章をA列に、

    あとA列にとかありますが、セルに入れられる文字数は 限られていますので
    あまり長いものは 無理です。
  • id:SALINGER
    私の回答では、全てテキストとして処理してるので
    HTMLの場合は途中にタグ(改行とか)が入ることがあります。
  • id:taroemon
    tanktさんいつもありがとうございます。

    HTMLの場合はまさにタグの間に挟まれてる文字を抽出したいのです。
    たとえば<title>と</title>の間に挟まれた文字を抽出したいのです。

    >あまり長いものは 無理です。
    エクセルの場合、セルの文字数の制限は1000文字でしたっけ?
    想定しているのはせいぜい100文字なので、
    制限を超えたらエラーで結構です。
  • id:taroemon
    SALINGERさんいつもありがとうございます。
    コメントを拝見する前に返事を書いていたので、
    私の返事は少しとんちんかんになってしまいました。


    htmlファイルの処理は重要なので、それに対応するか、
    別マクロにしていただけるとうれしいです。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません