« 旧型PSP-1000 ダウングレード&カスタムファームウェア | Main | 旧型PSPでワンセグ受信 »

Jan 04, 2008

Notes個人アドレス -> CSV

Notes6.5.3で作成した個人アドレス帳を汎用的なCSV形式のファイルへ
取り込むExce VBAを書きました。

------------------
Sub Start_Run()

'配列宣言
'***************************

Dim Values(65000, 2) As String
Dim Count As Integer

'CSVファイルの取り込み
'***************************

'Data削除
'***************************

    Sheets("Calc").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select

'Data取り込み
'***************************

    Workbooks.Open Filename:="D:\Address.csv"
    Columns("A:A").Select
    Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
        :=":", FieldInfo:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1)), _
        TrailingMinusNumbers:=True
    Columns("A:B").Select
    Selection.Copy
    Windows("NotesAddress2CSV.xls").Activate
    Range("A1").Select
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Columns("B:B").Select
    Selection.Insert Shift:=xlToRight
    Range("B1").Select
    ActiveCell.FormulaR1C1 = "=MID(RC[1],3,256)"
    Range("B1").Select
    Selection.Copy
    Range(Selection, Selection.End(xlDown)).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    Range("A1").Select

    Windows("Address.csv").Close

'配列への取り込み
'***************************

    For i = 1 To Range("A65536").End(xlUp).Row

        For j = 1 To 2
            Values(i, j) = Cells(i, j)
        Next j

    Next i   

'判断及びAddressシートへ取り込み
'***************************

For i = 1 To Range("A65536").End(xlUp).Row

    Select Case Values(i, 1)
        Case "LastName"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(1, 0).Value = Values(i, 2)
            End With

        Case "FirstName"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 1).Value = Values(i, 2)
            End With

        Case "OfficePhoneNumber"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 2).Value = Values(i, 2)
            End With

        Case "OfficeFAXPhoneNumber"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 3).Value = Values(i, 2)
            End With

        Case "CellPhoneNumber"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 4).Value = Values(i, 2)
            End With

        Case "AltFullNameSort_1"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 5).Value = Values(i, 2)
            End With

        Case "PhoneNumber"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 6).Value = Values(i, 2)
            End With

        Case "HomeFAXPhoneNumber"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 7).Value = Values(i, 2)
            End With

        Case "CompanyName"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 8).Value = Values(i, 2)
            End With

        Case "MailAddress"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 9).Value = Values(i, 2)
            End With

        Case "CompanyNameYomi"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 10).Value = Values(i, 2)
            End With

        Case "JobTitle"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 11).Value = Values(i, 2)
            End With

        Case "WebSite"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 12).Value = Values(i, 2)
            End With

        Case "FullName"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 13).Value = Values(i, 2)
            End With

        Case "InternetAddress"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 14).Value = Values(i, 2)
            End With

        Case "$Revisions"
            With ThisWorkbook.Worksheets("Address")
                .Range("B65536").End(xlUp).Offset(0, 15).Value = Values(i, 2)
            End With
    End Select

Next i

'番号付け
'***************************

Sheets("Address").Select

Count = Range("K65536").End(xlUp).Row
Count = Count - 1

    For i = 1 To Count
        Cells(i + 1, 1) = i
    Next i

End Sub

----------------------
Sub Clear()

'Sheet "Address" data削除
'***************************

    Sheets("Address").Select   
    Application.Goto Reference:="dat"
    Selection.ClearContents
    Range("A1").Select

'Sheet "Calc" data削除
'***************************

    Sheets("Calc").Select
    Cells.Select   
    Selection.ClearContents
    Range("A1").Select   
    Sheets("HowTo").Select

End Sub
----------------------


  ブログランキング

|

« 旧型PSP-1000 ダウングレード&カスタムファームウェア | Main | 旧型PSPでワンセグ受信 »

VBA」カテゴリの記事

Comments

Post a comment



(Not displayed with comment.)


Comments are moderated, and will not appear on this weblog until the author has approved them.



TrackBack


Listed below are links to weblogs that reference Notes個人アドレス -> CSV:

« 旧型PSP-1000 ダウングレード&カスタムファームウェア | Main | 旧型PSPでワンセグ受信 »