WILLCOM WX01J 電話帳vcfファイルをエクセルに取り込む | 備忘録　(。・_・。)ノ
AmebaAmeba 20th Anniv.ホームピグアメブロ
芸能人ブログ人気ブログ
新規登録
ログイン

備忘録　(。・_・。)ノ

備忘録

WILLCOM WX01J 電話帳vcfファイルをエクセルに取り込む

名前、カナ、電話番号３個をエクセルに取り込む

Option Explicit
Sub main()
    Dim lonNum As Long
    Dim strData As String
    Dim lonRow As Long
    Dim lonCol As Long
    Dim intSPos As Integer
    Dim intEPos As Integer
    lonNum = FreeFile
    Sheets("in").Select
    Open Cells(1, 2) For Input Access Read As #lonNum
    Sheets("out").Select
    Cells.Select
    Selection.Delete Shift:=xlUp
    lonRow = 1
    lonCol = 1
    Do While Not EOF(lonNum)
        Line Input #lonNum, strData
        Select Case lonCol
            Case 1, 2
                intSPos = InStr(1, strData, "N;CHARSET=SHIFT_JIS:")
                intEPos = InStr(intSPos + 20, strData, ";")
                If intSPos <> 0 And intEPos <> 0 Then
                    Cells(lonRow, lonCol) = Mid(strData, intSPos + 20, intEPos - (intSPos + 20))
                    lonCol = lonCol + 1
                End If
            Case 3, 4, 5
                intSPos = InStr(1, strData, "TEL")
                If intSPos <> 0 Then
                    intSPos = InStr(1, strData, ":")
                Else
                    intSPos = 0
                End If
                intEPos = Len(strData)
                If intSPos <> 0 And intEPos <> 0 Then
                    Cells(lonRow, lonCol) = "'" & Mid(strData, intSPos + 1, intEPos - intSPos)
                    lonCol = lonCol + 1
                End If
        End Select
        intSPos = InStr(1, strData, "END:VCARD")
        If intSPos <> 0 Then
            lonCol = 1
            lonRow = lonRow + 1
        End If
    Loop
    Close #lonNum
    Cells.EntireColumn.AutoFit
    Cells(1, 1).Select
    MsgBox "END"
End Sub