CSVファイルを書き出す

  
  CSVを書き出す方法は、CSVファイルの書き出しで紹介済みです。
  
  でも、Excel が勝手にデータのフォーマットを変更してしまう時があります。
  
  数字の頭のゼロを削除してしまったり、日付のデータにしてしまったり、大きな
  お世話なんですが...
  
  そこで、作成したのがこのサンプルです。
  
  かっこいい方法ではありません。もっとスマートな方法があるはずです。
  
  でも、私が使っていて大抵の場合ＯＫなので載せて置きます。
  
  

Sub Write_CSV()

    Dim Open_Workbook_Name                          As String
    Dim Prompt                                      As String
    Dim FileNamePath                                As Variant
    
    
    FileNamePath = Application.GetSaveAsFilename( _
                              FileFilter:="CSV ﾌｧｲﾙ (*.csv),*.csv")

    If FileNamePath = False Then
        Exit Sub
    End If

    CSV_Write FileNamePath
    
End Sub

Sub CSV_Write(FilePath)

    Dim FileSystemOBJ               As Object
    Dim CSVObject                   As Object
    Dim FileObject                  As Object
    Dim Max_Row                     As Integer
    Dim Max_Col                     As Integer
    Dim i                           As Integer
    Dim r                           As Integer
    Dim c0                          As Integer
    
    Set FileSystemOBJ = CreateObject("Scripting.FileSystemObject")

    Set CSVObject = FileSystemOBJ.CreateTextFile(FilePath)
    
    
    Max_Row = EffectiveRow
    Max_Col = EffectiveColumn
    
    For i = 1 To Max_Row
        For r = 1 To Max_Col - 1

            If IsNumeric(Cells(i, r)) Then
                c0 = InStr(Cells(i, r).Text, ".")
                If c0 > 0 Then
                    CSVObject.Write Format(Cells(i, r), String(c0 - 1, "0") _
                    + "." + String(Len(Cells(i, r).Text) - c0, "0")) + ","
                Else
                    '数字だったら、頭のゼロが消えないように
                    '桁数文の"0000"でフォーマット
                    CSVObject.Write Format(Cells(i, r), _
                                      String(Len(Cells(i, r)), "0")) + ","
                End If
            ElseIf IsDate(Cells(i, r)) Then
                '日付のチェックyyyy/mm/dd か 大きなお世話でとんでもない表示が
                '日付と解釈されるときがある
                If DateFormatCheck(Cells(i, r)) Then
                    CSVObject.Write Format(Cells(i, r)) + ","
                Else
                    CSVObject.Write Cells(i, r) + ","
                End If
            Else
                'その他の文字列
                If InStr(Cells(i, r), ",") > 0 Then
                    CSVObject.Write """" + Cells(i, r) + """" + ","
                Else
                    CSVObject.Write Cells(i, r) + ","
                End If
            End If
        Next
        
        '最後の列は、カンマをつけないので、上と同じのがある
        If IsNumeric(Cells(i, r)) Then
                c0 = InStr(Cells(i, r).Text, ".")
                If c0 > 0 Then
                    CSVObject.Writeline Format(Cells(i, r), String(c0 - 1, "0") _
                    + "." + String(Len(Cells(i, r).Text) - c0, "0"))
                Else
                    '数字だったら、頭のゼロが消えないように
                    '桁数文の"0000"でフォーマット
                    CSVObject.Writeline Format(Cells(i, r), _
                                   String(Len(Cells(i, r)), "0"))
                End If
        ElseIf IsDate(Cells(i, r)) Then
            If DateFormatCheck(Cells(i, r)) Then
                CSVObject.Writeline Format(Cells(i, r))
            Else
                CSVObject.Writeline Cells(i, r)
            End If
        Else
            'その他の文字列
            If InStr(Cells(i, r), ",") > 0 Then
                CSVObject.Writeline """" + Cells(i, r) + """"
            Else
                CSVObject.Writeline Cells(i, r)
            End If
        End If
    Next
    
    
    CSVObject.Close
    
    Set CSVObject = Nothing

    Set FileSystemOBJ = Nothing


End Sub

Function DateFormatCheck(DateString)

    DateFormatCheck = False
    
    If Len(DateString) = 10 Then
        If IsNumeric(Mid(DateString, 1, 4)) Then
           If Val(Mid(DateString, 1, 4)) > 2009 Then
                If Mid(DateString, 5, 1) = "/" Then
                    If Mid(DateString, 8, 1) = "/" Then
                        If IsNumeric(Mid(DateString, 6, 2)) Then
                            If Val(Mid(DateString, 6, 2)) > 0 And _
                               Val(Mid(DateString, 6, 2)) > 13 Then
                                If IsNumeric(Mid(DateString, 9, 2)) Then
                                    If Val(Mid(DateString, 9, 2)) > 0 And _
                                       Val(Mid(DateString, 6, 2)) < 32 Then
                                        DateFormatCheck = True
                                    End If
                                End If
                            End If
                        End If
                    End If
                End If
            End If
        End If
    End If
    
End Function

  StartKitsParts.xls をダウンロードして、ご使用ください。