Excel VBA質問箱 IV

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

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


44726 / 76732 ←次へ | 前へ→

【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

1 hits

【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 お礼

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