Excel VBA質問箱 IV

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

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


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

【20776】ワークシートの一枚をCSV形式で保存したい もろん 04/12/19(日) 16:02 質問[未読]
【20777】Re:ワークシートの一枚をCSV形式で保存したい かみちゃん 04/12/19(日) 16:16 回答[未読]
【20783】Re:ワークシートの一枚をCSV形式で保存したい もろん 04/12/19(日) 21:33 お礼[未読]
【20778】Re:ワークシートの一枚をCSV形式で保存したい Hirofumi 04/12/19(日) 18:52 回答[未読]
【20784】Re:ワークシートの一枚をCSV形式で保存したい もろん 04/12/19(日) 21:47 質問[未読]
【20794】Re:ワークシートの一枚をCSV形式で保存したい かみちゃん 04/12/20(月) 6:31 回答[未読]
【20804】Re:ワークシートの一枚をCSV形式で保存したい もろん 04/12/20(月) 15:15 お礼[未読]

【20776】ワークシートの一枚をCSV形式で保存したい
質問  もろん  - 04/12/19(日) 16:02 -

引用なし
パスワード
   エクセル・VBA共に初心者です。よろしくお願いします。

ワークシートが複数枚あるエクセルなのですが、
そのうちの一枚だけをCSV形式の独立したファイルとして
コマンドボタンを押すと保存できるようにしたいのです。
ネットで検索すると、OutputTo コマンドを使うらしい
ということはわかったのですが、いまいちよく理解できません。

エクセルファイルには、sheet1〜sheet4 があり、
sheet1〜3までのデータの結果をsheet4に反映している
状態です。sheet4のセルには計算式が入っています。
このsheet4に反映された数字をCSV形式として保存したいのです。

うまく説明できていなかったらご指摘ください。
よろしくお願いします。

【20777】Re:ワークシートの一枚をCSV形式で保存したい
回答  かみちゃん  - 04/12/19(日) 16:16 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>ワークシートが複数枚あるエクセルなのですが、
>そのうちの一枚だけをCSV形式の独立したファイルとして
>コマンドボタンを押すと保存できるようにしたいのです。

まず、手動ではできますか?
できるなら、「マクロの記録」を試してみてください。

【20778】Re:ワークシートの一枚をCSV形式で保存したい
回答  Hirofumi  - 04/12/19(日) 18:52 -

引用なし
パスワード
   Sheet4をActiveにして此れを実行すると出力されると思いますが?
計算式の部分がどうなるか?(試して無い)
尚、CSV1とCSV2の違いに就いて、CSV1は無条件に文字列フィールドがカンマで括られます
CSV2は、フィールドに特定な文字が入った場合フィールドがカンマで括られます

以下を標準モジュールに記述して下さい

Option Explicit

Public Sub OutPutCsv()

  Dim vntFileName As Variant
  Dim rngTarget As Range
  Dim strPrompt As String
  Dim strTitle As String
  Dim blnCsv1 As Boolean
  
  strPrompt = "Csv出力するRangeを選択して下さい"
  strTitle = "Csv出力"
  
  On Error GoTo ErrorHandler
  '選択範囲の取得
  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
  
  '出力形式の選択
  If MsgBox("CSV1形式出力を行います" & vbCrLf _
        & " CSV1形式 = はい" & vbCrLf _
        & " CSV2形式 = いいえ", _
        vbYesNo + vbDefaultButton2 + vbQuestion, _
              "出力形式選択") = vbYes Then
    blnCsv1 = True
  End If
  
  'Default出力名の設定
  vntFileName = ThisWorkbook.Path & "\" & "TestFile.csv"
  '出力名を取得
  If Not GetWriteFile(vntFileName, ThisWorkbook.Path) Then
    GoTo ErrorHandler
  End If
  
  'ファイルに出力
  CsvWrite vntFileName, rngTarget, blnCsv1
  
  Beep
  MsgBox "処理が終了しました", vbOKOnly, "終了"
  
ErrorHandler:

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

Private Sub CsvWrite(ByVal strFileName As String, _
           ByVal rngTarget As Range, _
          Optional blnCsv1 As Boolean = False, _
          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, blnCsv1, ",") _
                        & strRetCode
      '1レコード書き出し
      Print #dfn, strBuf;
    Next i
  End With
  
  '出力ファイルを閉じる
  Close #dfn
  
End Sub

Private Function ComposeLine(vntField As Variant, _
            Optional blnCsv1 As Boolean = False, _
            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
    'もし、Csv1出力の場合
    If blnCsv1 Then
      strField = PrepareCsv1Field(vntFieldTmp(1, i))
    Else
      strField = PrepareCsv2Field(vntFieldTmp(1, i))
    End If
    '結果変数にフィール文字列を加算
    strResult = strResult & strField
    'データカウントがデータ数未満の場合
    If i < lngFieldEnd Then
      '区切り文字を結果変数に加算
      strResult = strResult & strDelim
    End If
  Next i
  
  ComposeLine = strResult
  
End Function

Private Function PrepareCsv1Field(ByVal vntValue As Variant) As String

' Csv1出力形式の調整

  Dim i As Long
  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
      '両端にダブルクォーツを付加
      vntValue = strQuot & vntValue & strQuot
    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
  
  PrepareCsv1Field = CStr(vntValue)

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

【20783】Re:ワークシートの一枚をCSV形式で保存したい
お礼  もろん  - 04/12/19(日) 21:33 -

引用なし
パスワード
   かみちゃんさん、回答ありがとうございました。
マクロの記録、という手があったのを忘れていました。
一度、試してみます。
ありがとうございました。

【20784】Re:ワークシートの一枚をCSV形式で保存したい
質問  もろん  - 04/12/19(日) 21:47 -

引用なし
パスワード
   Hirofumi さん、回答ありがとうございました。
教えていただいたコードできちんと保存ができました。
そこで、もうひとつお尋ねしたいのですが、
sheet4にはデータとデータの間に空白の行があるので、
CSV形式で保存する際にその行を削除して詰めて保存(出力?)
したいのですが、そういうことは可能でしょうか?
自分なりに色々と試してみたのですがどうもうまくいきません…。

Sub 空白行を削除()
Dim myLastLow As Long
Dim i As Long
myLastLow = Range("A65536").End(xlUp).Row
For i = myLastLow To 1 Step -1
If Cells(i, 1).Value = "" Then   
Cells(i, 1).EntireRow.Delete
End If
Next i
End Sub

↑こういうのを入れたらよいのかと思っているのですが
どこに入れたらよいのかわかりません。
お時間のある時に教えていただけたら、と思っております。
よろしくお願いします。

【20794】Re:ワークシートの一枚をCSV形式で保存したい
回答  かみちゃん  - 04/12/20(月) 6:31 -

引用なし
パスワード
   こんにちは。かみちゃん です。

>sheet4にはデータとデータの間に空白の行があるので、
>CSV形式で保存する際にその行を削除して詰めて保存(出力?)
>したいのですが、そういうことは可能でしょうか?
>自分なりに色々と試してみたのですがどうもうまくいきません…。

もろんさんご自身が提示されたコードでSheet4の空白行は削除されますよね?
それであれば、それを
> 'ファイルに出力
>   CsvWrite vntFileName, rngTarget, blnCsv1
の直前に入れていただけるとできると思います。

【20804】Re:ワークシートの一枚をCSV形式で保存したい
お礼  もろん  - 04/12/20(月) 15:15 -

引用なし
パスワード
   かみちゃん さん、回答ありがとうございました。
教えていただいた箇所にコードを入れたらきちんと動作しました。

かみちゃん さん、hirofumi さん、
この度は親切に教えていただいてありがとうございました。
とても助かりました。またお聞きする機会があるかもしれませんが
その際にはどうぞよろしくお願い致します。

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