自動範囲指定のデータをCSVで保存したい。

質問

添付ファイルにあるようにデータ(量が変化します)があり、自動的に最後の行まで指定してその範囲をダイヤログボックスを表示させてCSVとして保存したい。
今特に問題がある点は、
・データのやり取りが出来ない点
・CSVとして保存できない。(上記の点においてブランクの表が作成される)

何卒宜しくお願い致します。

'現在開いているシートをCSVデータで保存する
Public Sub call_RangeSaveCSV()
Dim fPath As String
Dim fName As String
Dim rng As Range
Dim folderPath As String
Fldr = "ダウンロード"

'現在開いているブック情報をファイル名にするため、変数に格納
fPath = ActiveWorkbook.path & "\"
fName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".")) & "csv"

Application.DisplayAlerts = False

'現在選択しているセル情報をrngに格納
'Set Rng = Selection

Set rng = Range("L6").CurrentRegion

'新規ブック作成→rngをA1にコピー→CSV保存→CSV閉じる
Workbooks.Add
rng.Copy ActiveSheet.Range("A1")

'■ここでエラーが返ってきます。ダイヤログボックスを出して任意の場所と名前を付けたいのですが。。
ActiveWorkbook.SaveAs FileName:=fPath & fName, FileFormat:="Sample.csv", FileFilter:="CSVファイル(*.csv),*.csv")

ActiveWorkbook.SaveAs

ActiveWindow.Close

Application.DisplayAlerts = True

End Sub

回答No.3

HohoPapa · ベストアンサー

最終行をL列から求める場合と
220行固定の場合とを用意してみました。

作成してみてわかったことですが、
新たなシートにコピペして保存していますので
必然的に範囲末の空行は全数除かれることから、
最終行はあまり深く考えなくてもよさそうです。

Option Explicit

Public Sub Sample1()

　Dim rng As Range
　Dim FileName As Variant
　Dim wb As Workbook
　Dim LastRow As Long

　'最終行を取得　'L列の最終行
　LastRow = Cells(Rows.Count, 12).End(xlUp).Row
　'MsgBox LastRow

　'抽出するデータ範囲を定義
　Set rng = Range(Cells(6, 12), Cells(LastRow, 18)) 'L6～Rの最終行'

　'新規ブック作成→rngをA1にコピー
　Set wb = Workbooks.Add
　rng.Copy wb.ActiveSheet.Range("A1")

　'ダイアログで保存ファイル名のフルパスを取得
　FileName = Application.GetSaveAsFilename(InitialFileName:="規定の名称.csv", FileFilter:="CSVファイル,*.csv")
　If FileName = False Then
　　Exit Sub
　End If

　'保存し、クローズ
　Application.DisplayAlerts = False
　wb.SaveAs FileName:=FileName, _
　　FileFormat:=xlCSV, CreateBackup:=False
　Application.DisplayAlerts = True
　wb.Close

End Sub

Public Sub Sample2()

　Dim rng As Range
　Dim FileName As Variant
　Dim wb As Workbook
　Const LastRow = 220

　'抽出するデータ範囲を定義
　Set rng = Range(Cells(6, 12), Cells(LastRow, 18))

　'新規ブック作成→rngをA1にコピー
　Set wb = Workbooks.Add
　rng.Copy wb.ActiveSheet.Range("A1")

　'ダイアログで保存ファイル名のフルパスを取得
　FileName = Application.GetSaveAsFilename(InitialFileName:="規定の名称.csv", FileFilter:="CSVファイル,*.csv")
　If FileName = False Then
　　Exit Sub
　End If

　'保存し、クローズ
　Application.DisplayAlerts = False
　wb.SaveAs FileName:=FileName, _
　　FileFormat:=xlCSV, CreateBackup:=False
　Application.DisplayAlerts = True
　wb.Close

End Sub

回答No.2

HohoPapa

>例えば.「End(xlUp).Row」などを使って最後の行を判別すなどです。
どの列の最終行でしょうか？

お礼

補足し忘れたのですが、最終行は220となります。
宜しくお願い致します。

補足

何度もすみません。
データはL列、R列並列で表示されます。
そして文字で検索するのですが、その際には行数は変動します。10行だったり20行だったりします。
因みにL6,R６が最初の行となります。

宜しくお願い致します。

回答No.1

HohoPapa

提示された画像に行番号、列番号がないので
>自動的に最後の行まで
どのような条件で求めるのかがわかりません。

>Set rng = Range("L6").CurrentRegion
この条件でよく、
かつ、保存先、保存するファイル名を指定させるのであれば
後記のようなコードとなりましょう。

>自動的に最後の行まで
の判定方法と
保存するデータの開始行番号
保存するデータの列範囲がわかれば
コードを修正して再提示することが可能と思います。

Option Explicit

Public Sub call_RangeSaveCSV()
　　'Dim fPath As String
　　'Dim fName As String
　　Dim rng As Range
　　'Dim folderPath As String
　　Dim FileName As Variant
　　Dim wb As Workbook

'　　'現在開いているブック情報をファイル名にするため、変数に格納
'　　 fPath = ActiveWorkbook.Path & "\"
'　　fName = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".")) & "csv"
'
'　　Application.DisplayAlerts = False
'
'　　'現在選択しているセル情報をrngに格納
'　　'Set Rng = Selection

　　Set rng = Range("L6").CurrentRegion

　　'新規ブック作成→rngをA1にコピー
　　Set wb = Workbooks.Add
　　rng.Copy wb.ActiveSheet.Range("A1")

　　'ダイアログで保存ファイル名のフルパスを取得し、保存し、クローズ
　　FileName = Application.GetSaveAsFilename(InitialFileName:="規定の名称.csv", FileFilter:="CSVファイル,*.csv")
　　If FileName = False Then
　　　　Exit Sub
　　End If
　　wb.SaveAs FileName:=FileName, _
　　　　FileFormat:=xlCSV, CreateBackup:=False
　　wb.Close

　　'Application.DisplayAlerts = True

End Sub

補足

>自動的に最後の行までの判定方法
　例えば.「End(xlUp).Row」などを使って最後の行を判別すなどです。
保存するデータの開始行番号: L6
保存するデータの列範囲:R
です。
何卒宜しくお願い致します。