[[20150831154439]]　『CSV形式で保存』（くろ）　ページの最後に飛ぶ

『CSV形式で保存』（くろ）

いつもお世話になってます。
前任者（退職）が作ったものを変更したいのですが、上手くいかないので
ご教授宜しくお願いします。

変更したいのは
ファイル選択のための画面が出ないで保存をしたです。

自分で作成したものだと""が消えてしまいます。

【前任者作成】

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

　Worksheets.Add After:=Worksheets("D040")
　ActiveSheet.Name = "CSV010"
　Worksheets("D040").Activate

  Range("C3:D36").Copy
  Worksheets("CSV010").Range("a1").PasteSpecial Paste:=xlValues, Transpose:=True
  Worksheets("CSV010").Activate

  Dim myFname As Variant
  Dim Fno As Integer
  Dim buf As String
  Dim i As Long
  Dim j As Long
  Const QT As String = """"

  '「""」を入れるかどうか
  '0 =すべて, 1 =書式文字列のみ, 2 =すべてない
  Const SWITCH As Integer = 0

  '註：数値でも、'02 や書式文字列にしていれば、文字列として認識する

  myFname = Application.GetSaveAsFilename("D040", "テキスト ファイル (*.csv), *.csv")
  If myFname = False Then
    Exit Sub
  ElseIf Dir(myFname) <> "" Then
    If MsgBox("同じ名前のファイルがあります。上書きしますか？", vbQuestion) = vbCancel Then
      Exit Sub
    End If
  End If

  With ActiveSheet.UsedRange
    If WorksheetFunction.Count(.Cells) = 0 Then
      MsgBox "データが一つもありません。", vbCritical
      Exit Sub
    End If

    Fno = FreeFile
    Open myFname For Output As #Fno
    For i = 1 To .Rows.Count
      For j = 1 To .Columns.Count
        If Not IsEmpty(.Cells(i, 1).Value) Then

          If SWITCH = 0 Then
            buf = buf & "," & QT & .Cells(i, j).Text & QT

          ElseIf SWITCH = 1 Then
            If VarType(Cells(i, j).Value) = vbString Then
              buf = buf & "," & QT & .Cells(i, j).Text & QT
            Else
              buf = buf & "," & .Cells(i, j).Text
            End If

          Else
            buf = buf & "," & .Cells(i, j).Text
          End If
        End If
      Next j
      Print #Fno, Mid$(buf, 2)
      buf = ""
    Next i
  End With
  Close #Fno
  Worksheets("CSV010").Activate
  Application.DisplayAlerts = False
  Worksheets("CSV010").Delete
  Application.DisplayAlerts = True

End Sub

【くろ作成】

Sub 保存1()

     Dim FileName As String
     Dim bk As Workbook

   '***********************************************************
   '* 自ブック以外閉じる。
   '***********************************************************
     For Each bk In Workbooks
             If bk.Name <> ThisWorkbook.Name Then bk.Close True
     Next

   '***********************************************************
   '* csv作成保存。
   '***********************************************************

FileName = ThisWorkbook.Path & "\" & Worksheets("D040").Range("G2") & ".csv"

Worksheets("D040").Range("C3:D96").Copy
Worksheets.Add 'コピー先シート追加
ActiveSheet.Range("A1").PasteSpecial Paste:=xlValues, Transpose:=True

'CSV["" (クォーテーションマーク)]付き出力

  Dim Fno As Integer
  Dim buf As String
  Dim i As Long
  Dim j As Long
  Const QT As String = """"

  '「""」を入れるかどうか
  '0 =すべて, 1 =書式文字列のみ, 2 =すべてない
  Const SWITCH As Integer = 0

  '註：数値でも、'02 や書式文字列にしていれば、文字列として認識する

  With ActiveSheet.UsedRange
    If WorksheetFunction.Count(.Cells) = 0 Then
      MsgBox "データが一つもありません。", vbCritical
      Exit Sub
    End If

    Fno = FreeFile
    Open FileName For Output As #Fno
    For i = 1 To .Rows.Count
      For j = 1 To .Columns.Count
        If Not IsEmpty(.Cells(i, 1).Value) Then

          If SWITCH = 0 Then
            buf = buf & "," & QT & .Cells(i, j).Text & QT

          ElseIf SWITCH = 1 Then
            If VarType(Cells(i, j).Value) = vbString Then
              buf = buf & "," & QT & .Cells(i, j).Text & QT
            Else
              buf = buf & "," & .Cells(i, j).Text
            End If

          Else
            buf = buf & "," & .Cells(i, j).Text
          End If
        End If
      Next j
      Print #Fno, Mid$(buf, 2)
      buf = ""
    Next i
  End With
  Close #Fno

  FileName = Worksheets("D040").Range("G2")
  ActiveSheet.Move 'コピー先シートを新しいBookに
  ActiveSheet.Name = FileName
  FileName = ThisWorkbook.Path & "\" & FileName & ".csv"
  Application.DisplayAlerts = False
  ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlCSV '名前をつけて保存
  ActiveWorkbook.Close False '保存したので保存せずに閉じる
  Application.DisplayAlerts = True

End Sub

＜使用 Excel：unknown、使用 OS：Windows7 ＞

こんにちは

Open FileName For Output As #Fno
～
Close #Fno

で作ったCSVファイルに

ActiveWorkbook.SaveAs FileName:=FileName, FileFormat:=xlCSV '名前をつけて保存

で上書きしてますよね？

何故？

不要では？

（ウッシ） 2015/08/31(月) 16:28

（ウッシ）さん

早速返事ありがとうございます。
CSVファイルの部分はよく理解できてなくて無視してました。
無駄なことをしてたんですね。
ご指摘の部分を削除したら思い通りのものになりました。
ありがとうございます。
（くろ） 2015/08/31(月) 17:16

コメント返信：

[ 一覧(最新更新順) ]

[[20150831154439]] 『CSV形式で保存』（くろ） ページの最後に飛ぶ

[[20150831154439]]　『CSV形式で保存』（くろ）　ページの最後に飛ぶ