一日一コード 50.この前のやつ

EXCELのある列のデータをcsvに書き出すマクロ。
まあ、仕事で使うとデータの管理型文化なり便利になるはずだ。
なぜかエクセルファイルを会社のコンピュータで開けないのでここに書いておこう。

kaiseki.vb

Private Sub ExportButton_Click() '書き出すボタン

    Call ExportForMrKaiseki

End Sub
Private Sub ImportButton_Click() '読み込みボタン

    Call ImportForMrKaiseki

End Sub


'解析君用のファイルをまとめて書き出すマクロ。

'

' 2006/07/02 作成

'

'効能

'カレントディレクトリに

'url.txt group.txt group_title.txt title.txtを書き出す。

'

'仕様

'対象はシート1

'A2から下、空白まで　…　解析君用ID ((kk ID<文字列))

'B2から下、空白まで　…　グループID (group.txtの右側のやつ)

'C2から下、空白まで　…　グループ名 (group_title.txtの右側のやつ)

'D2から下、空白まで　…　タイトル名 (title.txtの右側のやつ)

'E2から下、空白まで　…　URL

Sub ExportForMrKaiseki()
    Call ExportTxt("url.txt", 1, 2, 5, 2) '//url.txt

    Call ExportTxt("group.txt", 1, 2, 2, 2) '//group.txt

    Call ExportTxt("group_title.txt", 2, 2, 3, 2) '//group_title.txt

    Call ExportTxt("title.txt", 1, 2, 4, 2) '//title.txt

    

End Sub
'解析君ファイルを読み込む。

'

'仕様　書き出しに同じ。

'

Sub ImportForMrKaiseki()

    

    Dim folderPath As Variant

    Dim fd As FileDialog

    

    'まず最初に解析君まとめファイルがあるフォルダを選択。

    Set fd = Application.FileDialog(msoFileDialogFolderPicker)

    If fd.Show = -1 Then

        folderPath = fd.SelectedItems.Item(1)

    Else

        'キャンセルされた

        End

    End If

    

    Set fd = Nothing

    

    Call ImportTxt(folderPath & "\url.txt", 1, 2, 5, 2) 'url.txt A2 / E2

    Call ImportTxt(folderPath & "\group.txt", 1, 2, 2, 2) 'group.txt A2 / B2

    Call ImportTxt(folderPath & "\group_title.txt", 2, 2, 3, 2) 'group_title.txt

    Call ImportTxt(folderPath & "\title.txt", 1, 2, 4, 2) 'title.txt

    

End Sub


'txt書き出し。

'

'引数

'exFileName : 書き出すファイル名

'L_c, L_r : 左側データのある位置 url.txt なら A2 (解析君ID データの開始位置)

'R_c, R_r : 右側データのある位置 url.txt なら E2 (URL　データの開始位置)

'

Function ExportTxt(exFileName As String, _

    L_Column As Integer, _

    L_Row As Integer, _

    R_Column As Integer, _

    R_Row As Integer)

    

    Dim exportFile

    Dim txt

    Dim currentPath As String

    Dim fullTextName As String

    

    'ファイル作成。

    Set exportFile = CreateObject("Scripting.FileSystemObject")

    currentPath = CurDir()

    fullTextName = exportFile.BuildPath(currentPath, exFileName)

    Set txt = exportFile.CreateTextFile(fullTextName, True, False) '強制上書き、ASCII

    

    Dim L As String 'セルの中身

    Dim R As String 'セルの中身

    Dim ln As Integer: ln = L_Row

    Dim rn As Integer: rn = R_Row

    

    'データ取得して書き込み。

    Do

        L = ActiveSheet.Cells(ln, L_Column).Value

        R = ActiveSheet.Cells(rn, R_Column).Value

        

        If (L = "") Then '空っぽだったら終了

            Exit Do

        End If

        

        'ファイルに書き出し。

        txt.WriteLine (L & "," & R)

        

        ln = ln + 1 '// L_Row++

        rn = rn + 1 '// R_Row++

        

    Loop While ln <> 0

    

    txt.Close

    Set exportFile = Nothing
End Function


'txt読み出し。

'

'exportTxtとほぼ同じ。

Function ImportTxt(imFileName As String, L_Column As Integer, L_Row As Integer, R_Column As Integer, R_Row As String)

    

    Dim importFile

    Dim txt

    Dim currentPath As Variant

    Dim fullTextName As String

    

    'ファイル読みだし。

    Set importFile = CreateObject("Scripting.FileSystemObject")

    Set txt = importFile.OpenTextFile(imFileName, 1, False, 0)

    

    Dim elment As Variant 'テキストに入っている要素

    Dim ln As Integer: ln = L_Row  'ln は行番号

    Dim rn As Integer: rn = R_Row

    

    'file not found エラーは放っとく。

    On Error GoTo ErrorHandle

    

    'データを読み込んでセルに書き出す。

    Do

        Dim line As String

        line = txt.ReadLine 'eofになったら勝手に終了?

        element = Split(line, ",", -1)

        

        'セルに書き込み。

        ActiveSheet.Cells(ln, L_Column).Value = element(0)

        ActiveSheet.Cells(rn, R_Column).Value = element(1)

        

        ln = ln + 1

        rn = rn + 1

    Loop While ln <> 0

    

ErrorHandle:  'eofに達したときはここに飛ぶ。

    

    txt.Close

    Set importFile = Nothing


End Function