データベースの中から「団体の名称」と「電話番号」だけ抜き出したいのですが可能でしょうか？

じゃあ、txtを取り込んでＡ列にデータが入っているとします。

B列を計算用に使います

B1に1

B2に

=IF(A2=A$1+SUM(B$1:B1),1,"")

B3以降にB2をコピーしてください。

C1に

=IF(B1=1,A1,"")

D1に

=IF($B2=1,"",IF($B1=1,$A2,""))

E1に

=IF(D1="","",IF($B3=1,"",IF($B1=1,$A3,"")))

F1に

=IF(E1="","",IF($B4=1,"",IF($B1=1,$A4,"")))

といれて、それぞれ、下の行にコピーします。

C列からF列を選択して「コピー」を選んで、別のシートで「形式を選択して貼り付け」を選んで「値」を選んで貼り付けてください。

データ番号の列で並べ替えをすると番号順のデータができると思います。

4番目の列に電話番号があると思います。

4行でないデータは違うところに電話番号があると思います。

また、電話番号だけ出せばいいのならば、

txtを取り込んでＡ列にデータが入っている時に並べ替えを行って、0から始まっている番号が電話番号になると思いますがどうでしょう？

データ番号が全角、最初が１以外、途中抜けてても対応。

ただし、名称や住所、電話番号に数値だけがあると、それもデータ番号と認識してしまう欠点があります。

Sub Macro()
    ' データファイルのパスを指定
    Const FILENAME = "C:\Documents and Settings\hogehoge\デスクトップ\hatena\test.txt"
    Dim FSO
    Dim TS
    Dim str As String
    Dim i As Long
    Dim f As Boolean
    Dim Meisyou As String
    Dim RE
    Dim reMatch
    
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "\d{1,4}?-\d{1,4}?-\d{1,4}"
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set TS = FSO.OpenTextFile(FILENAME, 1)
    i = 1
    Do Until TS.AtEndOfStream
        str = TS.ReadLine
        If f Then
            If IsNumeric(str) Then
                Cells(i, 1).Value = Meisyou
                
                Meisyou = ""
                i = i + 1
            Else
                If str <> "" Then
                    If Meisyou = "" Then
                        Meisyou = Trim(str)
                    Else
                        Set reMatch = RE.Execute(str)
                        If reMatch.Count > 0 Then
                            Cells(i, 1).Value = Meisyou
                            Cells(i, 2).Value = reMatch(0)
                            
                            Meisyou = ""
                            f = False
                            i = i + 1
                        End If
                    End If
                End If
            End If
        Else
            If IsNumeric(str) Then
                f = True
            End If
        End If
    Loop
    
    TS.Close
    Set TS = Nothing
    Set FSO = Nothing
    Set RE = Nothing
    MsgBox "終了"
End Sub