« 旧型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

TrackBack URL for this entry:
http://app.cocolog-nifty.com/t/trackback/68055/17571123

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

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