Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


7765 / 13644 ツリー ←次へ | 前へ→

【36962】CSVの作成(255文字を超える文字列) みき 06/4/19(水) 9:26 質問[未読]
【36973】Re:CSVの作成(255文字を超える文字列) Jaka 06/4/19(水) 11:34 発言[未読]
【37032】Re:CSVの作成(255文字を超える文字列... みき 06/4/20(木) 6:04 お礼[未読]
【37018】Re:CSVの作成(255文字を超える文字列) Hirofumi 06/4/19(水) 20:19 回答[未読]
【37033】Re:CSVの作成(255文字を超える文字列) みき 06/4/20(木) 6:07 お礼[未読]

【36962】CSVの作成(255文字を超える文字列)
質問  みき  - 06/4/19(水) 9:26 -

引用なし
パスワード
   VBAの初心者です。
EXECのシートを入力にして、そのシートの内容全てをCSVファイルとして書き出すことを考えています。以下がその書き出し部分です。

ActiveSheet.Copy
  With ActiveWorkbook
   .SaveAs Filename:=MyF, FileFormat:=xlCSV
   .Close SaveChanges:=False
  End With

このとき、ワークシート上のあるカラムに255文字以上(例;800文字)のデータが存在します。
実行後のCSVファイルを見ると、その255文字を超えるデータのみ255文字目までしかCSVファイルに書き出されていません。

どのようにしたら255文字以上のデータをCSVファイルに書き出すことが出来るかご教示お願い致します。(尚、固定長にすることはしたくありません)
宜しくお願い致します。

【36973】Re:CSVの作成(255文字を超える文字列...
発言  Jaka  - 06/4/19(水) 11:34 -

引用なし
パスワード
   ▼みき さん:
>尚、固定長にすることはしたくありません
この場合の固定長の意味が良くわかりませんでした。

1個1個のセル内容を取得して処理して行くしかないかと...。
取りあえずの例。

Sub csvOUT()
  Dim CSVFile_OUT As String, I As Long, II As Long
  Dim WtData As String
  CSVFile_OUT = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\xxxx.CSV"
  Open CSVFile_OUT For Output As #1
  For I = 1 To Cells(Rows.Count, "A").End(xlUp).Row
    WtData = Empty
    For II = 1 To 何列目まで??
      WtData = WtData & "," & Cells(I, II).Value
    Next
    Print #1, Mid(WtData, 2)
  Next
  Close #1
End Sub

【37018】Re:CSVの作成(255文字を超える文字列...
回答  Hirofumi  - 06/4/19(水) 20:19 -

引用なし
パスワード
   指定範囲をCsv出力するマクロです
多分此れでも出力出きると思います?

Option Explicit

Public Sub OutPutCsv()

  Dim vntFileName As Variant
  Dim rngTarget As Range
  Dim strPrompt As String
  Dim strTitle As String
  Dim strMessage As String
  
  strPrompt = "Csv出力するRangeを選択して下さい"
  strTitle = "Csv出力"
  strMessage = "処理を中止します"
  
  On Error GoTo Wayout
  '選択範囲の取得
  With Application
    'もし、選択範囲が無いなら
    If .Selection.Count = 1 Then
      Set rngTarget = ActiveSheet.UsedRange
    Else
      Set rngTarget = .Selection
    End If
    '選択範囲の取得
    Set rngTarget = .InputBox(Prompt:=strPrompt, _
                  Title:=strTitle, _
                  Default:=rngTarget.Address, _
                  Type:=8)
    rngTarget.Select
  End With
  On Error GoTo 0
  
  'Default出力名の設定
'  vntFileName = ThisWorkbook.Path & "\" & "TestFile.csv"

  '出力名を取得
  If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
    strMessage = "マクロがキャンセルされました"
    GoTo Wayout
  End If
  
  'ファイルに出力
  CsvWrite vntFileName, rngTarget
  
  strMessage = "処理が終了しました"
  
Wayout:

  '選択範囲の解除
  rngTarget(1).Select
  Set rngTarget = Nothing
  
  MsgBox strMessage, vbInformation
  
End Sub

Private Sub CsvWrite(ByVal strFileName As String, _
           ByVal rngTarget As Range, _
          Optional strRetCode As String = vbCrLf)

  Dim dfn As Integer
  Dim I As Long
  Dim j As Long
  Dim strBuf As String
  Dim lngCount As Long
  Dim vntField As Variant
    
  '空きファイル番号を取得します
  dfn = FreeFile
  '出力ファイルをOpenします
  Open strFileName For Output As dfn
    
  With rngTarget
    lngCount = .Columns.Count
    For I = 1 To .Rows.Count
      '1行分のDataをシートから読みこむ
      vntField = .Item(I, 1).Resize(, lngCount)
      '出力1レコード作成
      strBuf = ComposeLine(vntField, ",") & strRetCode
      '1レコード書き出し
      Print #dfn, strBuf;
    Next I
  End With
  
  '出力ファイルを閉じる
  Close #dfn
  
End Sub

Private Function ComposeLine(vntField As Variant, _
            Optional strDelim As String = ",") As String
'  レコード作成

  Dim I As Long
  Dim strResult As String
  Dim strField As String
  Dim lngFieldEnd As Long
  Dim vntFieldTmp As Variant
  
  'もし、データが複数なら
  If VarType(vntField) = vbArray + vbVariant Then
    vntFieldTmp = vntField
  Else
    ReDim vntFieldTmp(1 To 1, 1 To 1)
    vntFieldTmp(1, 1) = vntField
  End If
  'データ数の取得
  lngFieldEnd = UBound(vntFieldTmp, 2)
  'データ数繰り返し
  For I = 1 To lngFieldEnd
    strField = PrepareCsv2Field(vntFieldTmp(1, I))
    '結果変数にフィール文字列を加算
    strResult = strResult & strField
    'データカウントがデータ数未満の場合
    If I < lngFieldEnd Then
      '区切り文字を結果変数に加算
      strResult = strResult & strDelim
    End If
  Next I
  
  ComposeLine = strResult
  
End Function

Private Function PrepareCsv2Field(ByVal vntValue As Variant) As String

' Csv2出力形式の調整

  Dim I As Long
  Dim blnQuot As Boolean
  Dim lngPos As Long
  Const strQuot As String = """"
  
  '引数の変数内部形式に就いて
  Select Case VarType(vntValue)
    Case vbString  '文字列型
      'ダブルクォーツの処理
      I = 1
      lngPos = InStr(I, vntValue, strQuot, vbBinaryCompare)
      Do Until lngPos = 0
        vntValue = Left(vntValue, lngPos) & Mid(vntValue, lngPos + 1)
        I = lngPos + 2
        lngPos = InStr(I, vntValue, strQuot, vbBinaryCompare)
      Loop
      'ダブルクォーツで括るか否かの判断処理
      For I = 1 To 5
        lngPos = InStr(1, vntValue, Choose(I, ",", strQuot, _
                  vbCr, vbLf, vbTab), vbBinaryCompare)
        If lngPos <> 0 Then
          blnQuot = True
          Exit For
        End If
      Next I
      'ダブルクォーツで括るの判断の場合
      If blnQuot Then
        vntValue = strQuot & vntValue & strQuot
      End If
    Case vbDate   '日付型
      '日付が時分秒を持つなら
      If TimeValue(vntValue) > 0 Then
        vntValue = Format(vntValue, "yyyy/mm/dd h:mm:ss")
      Else
        vntValue = Format(vntValue, "yyyy/mm/dd")
      End If
  End Select
  
  PrepareCsv2Field = CStr(vntValue)

End Function

Private Function GetWriteFile(vntFileName As Variant, _
            Optional strFilePath As String) As Boolean

  Dim strFilter As String
  Dim strInitialFile As String
  
  'フィルタ文字列を作成
  strFilter = "CSV File (*.csv),*.csv," _
        & "Text File (*.txt),*.txt"
  '既定値のファイル名を設定
  strInitialFile = vntFileName
  '読み込むファイルの有るフォルダを指定
  If strFilePath <> "" Then
    'ファイルを開くダイアログ表示ホルダに移動
    ChDrive Left(strFilePath, 1)
    ChDir strFilePath
  End If
  '「ファイルを保存」ダイアログを表示
  vntFileName _
    = Application.GetSaveAsFilename(vntFileName, strFilter, 1)
  If vntFileName = False Then
    Exit Function
  End If

  GetWriteFile = True
  
End Function

【37032】Re:CSVの作成(255文字を超える文字列...
お礼  みき  - 06/4/20(木) 6:04 -

引用なし
パスワード
   ▼Jaka さん:
ありがとうございました。
上手く書き出すことができ助かりました。
みき
>▼みき さん:
>>尚、固定長にすることはしたくありません
>この場合の固定長の意味が良くわかりませんでした。
>
>1個1個のセル内容を取得して処理して行くしかないかと...。
>取りあえずの例。
>
>Sub csvOUT()
>  Dim CSVFile_OUT As String, I As Long, II As Long
>  Dim WtData As String
>  CSVFile_OUT = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\xxxx.CSV"
>  Open CSVFile_OUT For Output As #1
>  For I = 1 To Cells(Rows.Count, "A").End(xlUp).Row
>    WtData = Empty
>    For II = 1 To 何列目まで??
>      WtData = WtData & "," & Cells(I, II).Value
>    Next
>    Print #1, Mid(WtData, 2)
>  Next
>  Close #1
>End Sub

【37033】Re:CSVの作成(255文字を超える文字列...
お礼  みき  - 06/4/20(木) 6:07 -

引用なし
パスワード
   Hirofumiさん
お陰様で、上手く書き出すことができ助かりました。
コードの中に参考になる箇所が多く勉強になりました。
ありがとうございました。
みき

7765 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free