[[20200429154417]]　『xlsx形式からcsvファイルへ自動作成VBA』（Lammy）　ページの最後に飛ぶ

『xlsx形式からcsvファイルへ自動作成VBA』（Lammy）

セルの表示形式でユーザー定義している日付セルがあります。
具体的には、=TODAY()関数で本日の日付を取得し、ユーザー定義で

　[$-ja-JP]ggge"年"m"月"d"日""入金分"

としています。xlsx上は　令和2年4月29日入金分　と表記されますが、
vbaでいろいろ試してみたのですがどうしてもcsv出力結果が日付形式　2020/4/29　となってしまいます。

csv上でも　令和2年4月29日入金分　とする方法はありますでしょうか。

よろしくお願いします。

＜使用 Excel：Office365、使用 OS：Windows10 ＞

rをRange変数として、r.Value = r.Text とすれば表示そのものが値になります。
これを利用したらどうでしょうか。
・シートをいったん新しいブックにコピーして
・それに対して上記の操作を行ったうえで
・CSVとして保存
すればどうですか？

（ γ） 2020/04/29(水) 16:08

 2007だと、令和表示ではないけれど、普通に別名保存でCSV保存すると、
 表示形式のまんま
 平成32年4月29日入金分
 で、保存されるけどね。
 （表示形式は、ggge"年"m"月"d"日""入金分"、手作業保存）

 2003以前も表示形式のまんま保存されてたような・・・。
 マクロだと例のごとくかもしれないかも？
（BJ） 2020/04/29(水) 16:36

 もっとも、会社に残してきたCSV保存のマクロは、一セルづつ一々 yyyy/mm/dd に
 変換して保存するようにしてました。（Open … For Output 使用）

 今までの経験で、日付けはアメリカが基準であるから、下手に手を加えず、
 yyyy/mm/ddか、yyyy/m/d形式で保存するのが安全。
 であるから、[$-ja-JP]ggge"年"m"月"d"日""入金分" は、使い回しがしにくいかも。
 素直に2セルに分けた方がと良い思います。
（BJ） 2020/04/29(水) 16:47

＞vbaでいろいろ試してみた
無理にとは言いませんが、具体的にコードを示したりできますか？

    Sub 実験()
        ActiveSheet.Copy

        With Workbooks(Workbooks.Count)
            .SaveAs Filename:="T:\実験", FileFormat:=xlCSV
            .Close False
        End With

    End Sub

Office365／Windows10　の環境で仰る表示形式を適用してから、↑コードを試してみましたが、そのまま令和で保存されるようですが・・・

（もこな２） 2020/04/29(水) 17:21

もこな２様、お世話になります。
コードは以下の通りです。（ネットから拾ってきました）
小生、VBAは初心者で自分で一からは書けません。大変お恥ずかしい限りで恐縮ですm(__)m
もっとシンプルに書ければいいのですが・・・

Option Explicit
Const EXT As String = ".csv"

Sub CSV出力_通常()

    Dim Filepath As String
  Filepath = Application.GetSaveAsFilename(, "CSVファイル(*.csv),*.csv")

  If Filepath = "False" Then
    End
  End If

  Call csv.Output(ActiveSheet, Filepath)

  MsgBox Filepath & "にCSVファイルを出力しました"
End Sub

Option Explicit

'この標準モジュールは変更しない

Enum CSVCols

  Default = 0  '当初設定に従う
  force = 1    '強制的に処理を行う
  Ignore = 2   '処理を行わない
End Enum

'CSV出力メインロジック
'正常終了時TRUEを返す　※現状は、エラー処理を行っていないので常にTRUEが返る
'※charset に utf-8n と指定すると「BOMなしUTF-8」でCSVデータを作成する
Function Output(TargetSheet As Worksheet, ByVal Filepath As String, _

    Optional ByVal StartRow As Long = 1, Optional ByVal EndRow As Long = 0, _
    Optional ByVal StartCol As Long = 1, Optional ByVal EndCol As Long = 0, _
    Optional ByVal WithFormatCols As String = "", Optional ByVal WithoutFormatCols As String = "", _
    Optional ByVal WithQuoteCols As String = "", Optional ByVal WithoutQuoteCols As String = "", _
    Optional ByVal Delimitar As String = ",", Optional ByVal LineEndingCode As String = vbCr & vbLf, _
    Optional ByVal QuoteChar As String = """", Optional ByVal CharReplaceQuote As String = """""", _
    Optional ByVal Charset As String = "shift_jis") As Boolean

  '出力範囲（行）の指定
  If EndRow = 0 Then
    EndRow = getLastRow(TargetSheet)
  End If

  '出力範囲（列）の設定
  If EndCol = 0 Then
    EndCol = getLastColumn(TargetSheet)
  End If

  '各列出力時の書式付きかどうかの処理方法を配列に格納
  Dim FormatOptionOfColumns() As Long
  FormatOptionOfColumns = setOption(WithFormatCols, WithoutFormatCols, StartCol, EndCol)

  '各列出力時に”で囲むかどうかの処理方法を配列に格納
  Dim QuoteOptionOfColumns() As Long
  QuoteOptionOfColumns = setOption(WithQuoteCols, WithoutQuoteCols, StartCol, EndCol)

  'CSV出力データ準備
  Dim csvData As String

  Dim rowData() As String
  ReDim rowData(0 To EndCol - StartCol) As String

  Dim R As Long
  Dim C As Long
  For R = StartRow To EndRow
    For C = StartCol To EndCol
      rowData(C - StartCol) = convertFormatTowriteCSVFile(TargetSheet.Cells(R, C), StartCol, _
                                            Delimitar, QuoteChar, CharReplaceQuote, _
                                            FormatOptionOfColumns, QuoteOptionOfColumns)
    Next

  '1行のデータをデリミタでつないで、改行を付加
    csvData = csvData & Join(rowData, Delimitar) & LineEndingCode
  Next

'csv出力

  Output = writeCSVFile(csvData, Filepath, Charset)

End Function

Private Function getLastRow(TargetSheet As Worksheet) As Long

  Dim Row As Long
  Dim Column As Long

'UsedRangeで取得した最下行の右→左、最下行の1段上の右→左と走査していく

  For Row = TargetSheet.UsedRange.Row + TargetSheet.UsedRange.Rows.Count - 1 To 1 Step -1
    For Column = TargetSheet.UsedRange.Column + TargetSheet.UsedRange.Columns.Count - 1 To 1 Step -1
      If TargetSheet.Cells(Row, Column).Value <> "" Then
        GoTo Finally
      End If
    Next
  Next

Finally:

  getLastRow = Row
End Function

Private Function getLastColumn(TargetSheet As Worksheet) As Long

  Dim Row As Long
  Dim Column As Long

'UsedRangeで取得した最右行の下→上、最右行の1列左の下→上と走査していく

  For Column = TargetSheet.UsedRange.Column + TargetSheet.UsedRange.Columns.Count - 1 To 1 Step -1
    For Row = TargetSheet.UsedRange.Row + TargetSheet.UsedRange.Rows.Count - 1 To 1 Step -1
      If TargetSheet.Cells(Row, Column).Value <> "" Then
        GoTo Finally
      End If
    Next
  Next

Finally:

  getLastColumn = Column
End Function

'CSV出力時のオプション
'（１．書式付で出力するか、２．「”」で囲むかについての設定）
'を使いやすい形（配列）に格納する
Private Function setOption(WithCols As String, WithoutCols As String, minCol As Long, maxCol As Long)

  WithCols = "," & WithCols & ","
  WithoutCols = "," & WithoutCols & ","

  Dim ret() As Long
  ReDim ret(0 To maxCol - minCol)

  Dim C As Long
  For C = LBound(ret) To UBound(ret)
    If InStr(WithCols, "," & C + 1 & ",") Then
      ret(C) = CSVCols.force
    ElseIf InStr(WithoutCols, "," & C + 1 & ",") Then
      ret(C) = CSVCols.Ignore
    Else
      ret(C) = CSVCols.Default
    End If
  Next

  setOption = ret
End Function

'各セルの値をCSV出力用に加工する
Private Function convertFormatTowriteCSVFile(R As Range, BaseCol As Long, _

         Delimitar As String, QuoteChar As String, CharReplaceQuote As String, _
         FormatOptionOfColumns() As Long, QuoteOptionOfColumns() As Long)
  Dim Val As Variant
  Val = R.Value

  '書式を適用
  If FormatOptionOfColumns(R.Column - BaseCol) = CSVCols.force Or _
    FormatOptionOfColumns(R.Column - BaseCol) = CSVCols.Default And addFormat(Val) Then
    Val = R.Text
  End If

  '「”」で囲む　※データ中に「”」があれば、指定の値に置き換える
  If QuoteOptionOfColumns(R.Column - BaseCol) = CSVCols.force Or _
    QuoteOptionOfColumns(R.Column - BaseCol) = CSVCols.Default And AddQuote(Val, Delimitar, QuoteChar) Then
    Val = QuoteChar & Replace(Val, QuoteChar, CharReplaceQuote) & QuoteChar
  End If

  convertFormatTowriteCSVFile = Val
End Function

'CSVCols.Defaultの場合に、書式を適用するかどうかの判定
Private Function addFormat(Val As Variant) As Boolean

    addFormat = False
End Function

'CSVCols.Defaultの場合に、「”」で囲むかの判定。
Private Function AddQuote(Val As Variant, Delimitar As String, QuoteChar As String) As Boolean

  If InStr(Val, Delimitar) Or InStr(Val, QuoteChar) Or _
     InStr(Val, vbLf) Or InStr(Val, vbCr) Then
    AddQuote = True
  Else
    AddQuote = False
  End If
End Function

'CSVデータ出力
'正常終了時TRUEを返す
Private Function writeCSVFile(csvData As String, Filepath As String, Charset As String) As Boolean

  Dim removeBom As Boolean

  If Charset = "utf-8n" Then
    Charset = "utf-8"
    removeBom = True
  Else
    removeBom = False
  End If

'本来は、下記で変数宣言したいが、参照設定しない場合のために、変数宣言をObjectにする
' Dim ST As ADODB.Stream

  Dim ST As Object
  Set ST = CreateObject("ADODB.stream")

  With ST
    .Mode = 3  'adModeReadWrite
    .Type = 2  'adTypeText
    .Charset = Charset

    .Open
    .WriteText csvData, 0  'adWriteChar
  End With

  If removeBom Then
'以下、Bom抜き処理
'BOM部分を読み飛ばして、その先から読み込む
    ST.Position = 0
    ST.Type = 1  'adTypeBinary
    ST.Position = 3

'別のストリームにバイナリとしてコピー
' Dim ST2 As ADODB.Stream

    Dim ST2 As Object
    Set ST2 = CreateObject("ADODB.stream")

    With ST2
      .Mode = 3  'adModeReadWrite
      .Type = 1  'adTypeBinary
      .Open

      .Write ST.Read

      .SaveToFile Filepath, 2  'adSaveCreateOverWrite
      .Close
    End With
  Else
    ST.SaveToFile Filepath, 2  'adSaveCreateOverWrite
  End If

  ST.Close
  writeCSVFile = True
End Function
（Lammy） 2020/04/29(水) 18:57

おもったより。。というかかなり複雑ですね。
ほとんど読んでませんが、それ全部必要なんでしょうか？

とりあえず、提示のマクロで体裁などの調整をしてから、示したよう、シートを別ブックにコピーして、CSV形式で保存するようにしてみてはどうでしょうか？

（もこな２） 2020/04/29(水) 21:01

もこな２様
お世話になります。

確かに仰る通り、全部必要かどうかといわれれば、？です。
現段階では、xlsxファイルの日付形式ユーザー定義のまま
VBA自動でcsvファイルを作成することは難しそうですね。

もうちょっと勉強してみます。
ありがとうございました。
（Lammy） 2020/04/29(水) 21:32

「【超簡単】ワンタッチでエクセルからCSV出力するVBAプログラム」
https://www.excelspeedup.com/csvsyuturyoku/
がそのファイルの出所でしょう。

その中に、書式どおりに出力するオプションがあります。
マニュアルをよく読みましょう。
WithFormatCols　というのがそれです。
そこで指定した列に対しては、
.Valueでなく、.Textを使用するようなコードになっています。

・ツールを使うなら、ご自分でマニュアルをよく読みましょう。
・ツールを使わなければ、普通に　令和2年4月29日入金分　という形式で保存されます。
どちらか徹底してください。
（ γ） 2020/04/29(水) 21:49

 >vbaでいろいろ試してみたのですが

 どこをどう試したのか書いてませんけど。
（BJ） 2020/04/30(木) 00:48

＞ネットから拾ってきました
それは作者に失礼ですな。きちんと出典を明確にすべきでし、
作者に対するリスペクトが全然感じられません。ゴミじゃないんだから。

# 所詮、こちらの質問回答も便利屋くらいに思っているんでしょうな。
# そういえば少し前に、あなたから説明も不十分なまま、
# 仕事をおっつけられかけたことを想い出した。
# 自分ではろくすっぽ調べもトライもせずにというスタンスは相変わらずのようです。

（γ） 2020/04/30(木) 06:56

コメント返信：

[ 一覧(最新更新順) ]

[[20200429154417]] 『xlsx形式からcsvファイルへ自動作成VBA』（Lammy） ページの最後に飛ぶ

[[20200429154417]]　『xlsx形式からcsvファイルへ自動作成VBA』（Lammy）　ページの最後に飛ぶ