Excel VBA質問箱 IV

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

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


71801 / 76733 ←次へ | 前へ→

【9425】Re:EXCELからCSVに変更する際に・・・・
回答  りん E-MAIL  - 03/12/3(水) 19:45 -

引用なし
パスワード
   テーブル さん、こんばんわ。

>何か私がまちがっていたみたいです。
 書式だけ設定してあるセルも出力対象になります。csvも同様のはずです。
が、必要ないと思われる部分は出力しない方法もあるので書いておきます。
(組んでる間にレスがついてました)

Sub test()
  Dim Cmax As Integer, Rmax As Long, CC As Integer, RR As Long
  Dim Cfile As String
  Dim ws As Worksheet
  Set ws = ActiveSheet '現在表示中のシートが対象
  '
  'NewFile
  With ws.Parent
   If .Path = "" Then
     '初めての保存の時はカレントフォルダに
     Cfile = .Name & ".csv"
   Else
     '保存されたブックの時はブックと同じフォルダに
     Cfile = .FullName
     Cfile = Left(Cfile, Len(Cfile$) - 3) & "csv"
   End If
  End With
  '出力範囲
  With ws.UsedRange
   Cmax = .Cells(.Count).Column
   Rmax = .Cells(.Count).Row
  End With
  '書式のみ設定してあるセルもUsedRangeに含まれるので、データのある右下端を求める
  With Application.WorksheetFunction
   '最終列をチェックする
   For CC = Cmax To 2 Step -1
     If .CountA(ws.Columns(CC)) > 0 Then
      Cmax = CC: Exit For
     End If
   Next
   '最終行をチェックする
   For RR = Rmax To 2 Step -1
     If .CountA(ws.Rows(RR)) > 0 Then
      Rmax = RR: Exit For
     End If
   Next
  End With
 
  '
  With ws
   Open Cfile For Output As #2
     For RR = 1 To Rmax
      For CC = 1 To Cmax
        If CC > 1 Then Print #2, ",";
        '数字は”でくくらない場合などはここで分岐
        Print #2, Chr(34) & .Cells(RR, CC).Value & Chr(34);
      Next
      Print #2, "" '改行
     Next
   Close #2
  End With
  '
  Set ws = Nothing
End Sub

こんな感じです。行内、列内に値を含む最後を探してから書き出しています。
あと、変数DCは使い忘れです。書き出しの時のChr(34)を置き換えようとして忘れていました、すみません。ので、今回は省略してあります。

2 hits

【9396】EXCELからCSVに変更する際に・・・・ テーブル 03/12/2(火) 15:25 質問
【9401】Re:EXCELからCSVに変更する際に・・・・ りん 03/12/3(水) 0:28 回答
【9417】Re:EXCELからCSVに変更する際に・・・・ テーブル 03/12/3(水) 14:43 お礼
【9424】Re:EXCELからCSVに変更する際に・・・・ テーブル 03/12/3(水) 19:26 お礼
【9425】Re:EXCELからCSVに変更する際に・・・・ りん 03/12/3(水) 19:45 回答
【9432】Re:EXCELからCSVに変更する際に・・・・ テーブル 03/12/4(木) 10:54 お礼

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