[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『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.