文字操作 CSV形式テキストファイル出力

VB&VBA
FROG ふろっぐ
 
  • オプション

    本文印刷

    お気に入りに追加

  • 検索

    Googlewwwjp-ia
     

    Googlewwwjp-ia
     
  • 情報

  • 関連

[VB&VBA][文字操作 CSV形式テキストファイル出力]

Sub AddCSV()
'*******************************
'CSV形式テキストファイル出力
'*******************************
'フィールド名に「日」の文字を含む場合"yyyy/mm/dd"形式にする。
On Error GoTo error:

Dim sht(1 To 2) As Worksheet
Dim bok As Workbook
Dim MyPath As String
Dim MyPath2 As String
Dim i As Byte
Dim j As Long
Const shtFol As String = "\Backup"
Dim Fso As Object
Dim Chack As Boolean

Set bok = Workbooks("pdpData.xls")
Set sht(1) = bok.Worksheets("会計伝票")
Set sht(2) = bok.Worksheets("カルテ")

Application.ScreenUpdating = False
   
Set Fso = CreateObject("Scripting.FileSystemObject")
    
MyPath2 = bok.Path & shtFol
    
Chack = Fso.Folderexists(MyPath2)
    
If Chack = False Then   '無ければ作成
    Fso.createfolder (MyPath2)
End If
   
Set Fso = Nothing
   
MyPath = bok.Path & shtFol & "\"


For i = 1 To 2
    With sht(i)
    If Dir(MyPath & .Name & ".csv") <> "" Then Kill MyPath & .Name & ".csv"
        Application.DisplayAlerts = False
            For j = 1 To .Range("A1").SpecialCells(xlCellTypeLastCell).Column
                If InStr(1, .Cells(1, j).Value, "日") <> 0 Then
                    .Columns(j).NumberFormat = "yyyy/mm/dd"
                End If
            Next j
        .Copy
        ActiveWorkbook.SaveAs Filename:=MyPath & .Name & ".csv", _
            FileFormat:=xlCSV, CreateBackup:=False
        ActiveWorkbook.Close SaveChanges:=False
        Application.DisplayAlerts = True
    End With
    Set sht(i) = Nothing
Next i

Set bok = Nothing

MsgBox MyPath & "バックアップをしました", 0, "Backup"

Exit Sub
error:
MyErrorMsg
End Sub





Production Japan Import Application. Since 1998