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

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

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

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

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

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