テキストファイルから特定の文字Excel(できればcsv)ファイルへ転記したい

投稿者 : ボールペン     投稿日時 : 2024/10/21(Mon) 16:03:10     OS : Windows 10     EXCEL : Excel 2013

---

下記の①～③の作業を行いたいです。
①②は手動で行いますが、③は件数が多いためVBAで行いたいと思っています。



①iPhoneに登録されている電話帳のリストをvcardへ出力
②出力されたvcardの内容をメモ帳へ出力
③出力されたメモ帳のデータの中から、「名前」、「電話番号」、「ふりがな」を抽出してExcelの各セルへ貼り付け



以下は②で出力したvcardデータのサンプルです。



BEGIN:VCARD
VERSION:3.0
PRODID:-//Apple Inc.//iOS 17.6.1//EN
N:○○○○(名前);;;;
FN:名前
X-PHONETIC-LAST-NAME:フリガナ
item1.TEL;type=pref:012 3456 7890(ハイフンなしの電話番号)
item1.X-ABLabel:社用携帯
TEL;type=CELL;type=VOICE:012 3456 7890(ハイフンなしの電話番号)
REV:2024-08-22T07:30:00Z
END:VCARD
BEGIN:VCARD
VERSION:3.0
.
.
.

上記のデータから
名前(○○○○)、
ふりがな(「X-PHONETIC-LAST-NAME:」から行末までの部分)、
電話番号(「item1.TEL;type=pref:」から行末まで、「TEL;type=CELL;type=VOICE:」から行末までの部分)

を抽出して

名前　ふりがな　電話番号(1)　電話番号(2)　…
名前　ふりがな　電話番号(1)　電話番号(2)　…
名前　ふりがな　電話番号(1)　電話番号(2)　…
…

とExcelに貼り付けていきたいです。
(BEGIN:VCARD～END:VCARDで電話帳１人分のデータ)

※サンプルでは電話番号は２つですが、３つ以上登録している人もいるので、その場合は同じ行に続けて貼り付けたい
※サンプル9行目の「TEL;type=CELL;」は「TEL;type=HOME」や「TEL;type=WORK」の場合もあります。
※Excelのバージョンは2013と2021の2台分あります。


以上です。
長文で申し訳ありませんが、よろしくお願いします。

投稿者 : ボールペン     投稿日時 : 2024/10/21(Mon) 16:20:46

---

すみません。タイトル脱字してました。
「テキストファイルから特定の文字列を Excel(できればcsv)ファイルへ転記したい」です。

投稿者 : ボールペン     投稿日時 : 2024/10/21(Mon) 16:49:01

---

Excelのバージョンの件ですが、
PCは2台あり2013、2021どちらも使えるということを言いたかったです。
言葉足らずで申し訳ないです。

投稿者 : ピロリ     投稿日時 : 2024/10/21(Mon) 20:16:29

---

■[質問] ボールペンさん（2024-10-21 16:03:10）の記事
＞ ①②は手動で行いますが、③は件数が多いためVBAで行いたいと思っています。
＞
＞ ①iPhoneに登録されている電話帳のリストをvcardへ出力
＞ ②出力されたvcardの内容をメモ帳へ出力
＞ ③出力されたメモ帳のデータの中から、「名前」、「電話番号」、「ふりがな」を抽出してExcelの各セルへ貼り付け
出力されたテキストデータの形式が書かれてないので、文字コードが UTF-8コード，改行コードが CRLF 前提のサンプルです。
csvファイルへの出力については割愛しますが、 <vba csv出力> などで検索できると思います。

Sub Sample()
    Dim Target As String, buf As String, tmp As Variant
    Dim i As Long, r As Long, c As Long
    Target = ThisWorkbook.Path & "\" & "vcard.txt"  'このブックと同フォルダに「vcard.txt」
    With CreateObject("ADODB.Stream")
        .Charset = "UTF-8"                          '文字コード：UTF-8コードの前提
        .Open
        .LoadFromFile Target
        buf = .ReadText
        .Close
        tmp = Split(buf, vbCrLf)                    '改行コード：CRLFの前提
        For i = 0 To UBound(tmp)
            If InStr(tmp(i), "N:") = 1 Then                         '名前ならば、
                r = r + 1: c = 3
                Cells(r, "A") = Replace(Mid(tmp(i), 3), ";", "")
            End If
            If InStr(tmp(i), "X-PHONETIC-LAST-NAME:") = 1 Then      'フリガナならば、
                Cells(r, "B") = Mid(tmp(i), 22)
            End If
            If InStr(tmp(i), "TEL;type=") > 0 Then                  '電話番号ならば、
                Cells(r, c) = Mid(tmp(i), InStrRev(tmp(i), ":") + 1)
                c = c + 1
            End If
        Next i
    End With
End Sub

投稿者 : ボールペン     投稿日時 : 2024/10/22(Tue) 09:23:05

---

ピロリさん、回答いただきありがとうございます。
VBA初心者なのでいろいろ言葉足らずですみません。
いただいたコードで試してみて、次は自分で作れるよう勉強します。
ありがとうございました。

投稿者 : ボールペン     投稿日時 : 2024/10/22(Tue) 09:47:05

---

少し動かしてみましたが、問題なさそうです。
ありがとうございました。