朧の.Netの足跡
問合せ先:support@oborodukiyo.info サイト内検索はこちら
エクセルVBA シートの表のデータをCSVファイルに書き込む汎用的な関数





エクセルのVBAでアクティブなシートのデータをCSVファイルに書き込む汎用的な関数を作ってみました。
writeCSVwithSingleQuotation1関数は、’で囲んで、カンマで区切って、セルの生データをCSVファイルに保存するの関数です。
writeCSVwithSingleQuotation2関数は、’で囲んで、カンマで区切って、セルの書籍設定が効いた表示データをCSVファイルに保存するの関数です。
writeCSVwithDoubleQuotation1関数は、”で囲んで、カンマで区切って、セルの生データをCSVファイルに保存するの関数です。
writeCSVwithDoubleQuotation2関数は、”で囲んで、カンマで区切って、セルの書籍設定が効いた表示データをCSVファイルに保存するの関数です。
writeCSVwithNoQuotation1関数は、カンマで区切るだけで、セルの生データをCSVファイルに保存するの関数です。
writeCSVwithNoQuotation2関数は、カンマで区切るだけで、セルの書籍設定が効いた表示データをCSVファイルに保存するの関数です。
writeCSV関数は各関数から呼び出されて、CSVファイルに書き込むメインの処理の関数です。
ファイル名と保存先のパスは各関数で希望するものに変更してください。

なお、保存したいシートをアクティブにして、保存したい表の中のいずれかのセルを選択した状態で、マクロから呼び出してください。

Macでの注意

Macでは、エクセルファイルをOneDriveから、ローカルのMacにコピーしてから使用してください。
また、CSVファイルの名前の前にある¥記号を/(スラッシュ)に変更してみてください。
それでうまく動かない時は報告していただけると助かります。



Option Explicit

Public Sub writeCSVwithSingleQuotation1()
    Dim filePath As String
    
    filePath = ThisWorkbook.Path & "\sample01.csv"
    writeCSV filePath, "'", True
End Sub

Public Sub writeCSVwithSingleQuotation2()
    Dim filePath As String
    
    filePath = ThisWorkbook.Path & "\sample01.csv"
    writeCSV filePath, "'", False
End Sub

Public Sub writeCSVwithDoubleQuotation1()
    Dim filePath As String
    
    filePath = ThisWorkbook.Path & "\sample01.csv"
    writeCSV filePath, """", True
End Sub

Public Sub writeCSVwithDoubleQuotation2()
    Dim filePath As String
    
    filePath = ThisWorkbook.Path & "\sample01.csv"
    writeCSV filePath, """", False
End Sub

Public Sub writeCSVwithNoQuotation1()
    Dim filePath As String
    
    filePath = ThisWorkbook.Path & "\sample01.csv"
    writeCSV filePath, "", True
End Sub

Public Sub writeCSVwithNoQuotation2()
    Dim filePath As String
    
    filePath = ThisWorkbook.Path & "\sample01.csv"
    writeCSV filePath, "", False
End Sub

'メインの処理用関数
Private Sub writeCSV(ByVal fileName As String, ByVal quote As String, ByVal rawData As Boolean)
    Dim fileNum As Integer
    Dim buf As String
    '最初にアクティブだったシート
    Dim ws As Worksheet
    'データがあると思われるセル範囲
    Dim dataRange As Range
    Dim rowStart As Integer
    Dim rowEnd As Integer
    Dim colStart As Integer
    Dim colEnd As Integer
    
    Dim strQuote As String
    'ワークシートの行番号
    Dim i As Integer
    Dim j As Integer
    If fileName = "" Then
        Exit Sub
    End If
    
    '最初にアクティブなシートにデータがあるとしてシートを記憶しておく
    Set ws = ActiveSheet
    'データ範囲を自動認識
    Set dataRange = ActiveCell.CurrentRegion
    'データ範囲をFORループで処理するために行番号と列番号の範囲を取得しておく
    rowStart = dataRange.row
    rowEnd = rowStart + dataRange.Rows.Count - 1
    colStart = dataRange.Column
    colEnd = colStart + dataRange.Columns.Count - 1
        
    'データの間のカンマ等を作っておく
    strQuote = quote & "," & quote
    
    '空いているファイル番号を取得
    fileNum = FreeFile
    '書き込みでファイルを開く
    Open fileName For Output As #fileNum
    
    For i = rowStart To rowEnd
        '各行の先頭のクォテーションを入れて置く
        buf = quote
        'CSVファイルに書き込む
        For j = colStart To colEnd
            '生データを書き込むか、書式設定が効いた表示されているデータで書き込むかで分岐
            If rawData = True Then
                If quote = """" Then
                    buf = buf & Replace(ws.Cells(i, j).Value, """", """""")
                Else
                    buf = buf & ws.Cells(i, j).Value
                End If
            Else
                If quote = """" Then
                    buf = buf & Replace(ws.Cells(i, j).Text, """", """""")
                Else
                    buf = buf & ws.Cells(i, j).Text
                End If
            End If
            
            '1行の最後のデータでなければデータ間を入れて置く
            If j <> colEnd Then
                buf = buf & strQuote
            End If
        Next j
        
        buf = buf & quote
        '1行を書き込む
        Print #fileNum, buf
        
    Next i
    
    Close #fileNum
    
    '変数の開放
    Set dataRange = Nothing
    Set ws = Nothing
    
End Sub








良いやや良い普通やや悪い悪い

投稿日時評価コメント