[[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


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.