Sub CSVファイル作成()
    Dim TMPNAME As String, txtTMPNAME As String, myPath As String, szStr As String
    Dim Response As String
    Dim strMySheet As String
    Dim lngLastRow As Long
    
    '余裕を持った使用最大行数
    Const MaxRowsCount As Long = 30000
          
    'このファイルへのPath
    myPath = ThisWorkbook.Path
    
    'このファイルの名前
    TMPNAME = ThisWorkbook.Name
    
    '現在のシート名
    strMySheet = ActiveSheet.Name
    
    'テキスト用ファイルの名前(このファイル名.csv)
    txtTMPNAME = Left(TMPNAME, Len(TMPNAME) - 5) & ".csv"
    
    szStr = szStr & "CSVファイルを作成します" & Chr(13) & Chr(10)
    szStr = szStr & "" & Chr(13) & Chr(10)
    szStr = szStr & "作成場所 → このファイルと同じ階層(フォルダ)" & Chr(13) & Chr(10)
    szStr = szStr & "(" & myPath & ")" & Chr(13) & Chr(13) & Chr(10)
    szStr = szStr & "ファイル名 → " & txtTMPNAME & Chr(13) & Chr(10)
    
    Response = MsgBox(prompt:=szStr, Buttons:=vbOKCancel + vbInformation, Title:="CSVファイルの作成")
    If Response = vbCancel Then Exit Sub
    
    Application.ScreenUpdating = False
    
    'テキスト用ファイルの名前(このファイル名.csv)にPathを含める
    txtTMPNAME = myPath & "\" & txtTMPNAME
    
    'データ最終行を取得
'    ActiveSheet.Select
    lngLastRow = Cells(MaxRowsCount, "D").End(xlUp).Row
    
    '★データ範囲を選択
    Range("D4", Cells(lngLastRow, "I")).Select
    Selection.Copy
    
    'CSV作成用のワークシートを追加
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    
    '追加したシートに貼り付け
    Worksheets(Worksheets.Count).Select
    Range("A1").Select
    ActiveSheet.Paste
    
    lngLastRow = Cells(MaxRowsCount, "A").End(xlUp).Row
    
    
'-----------------------------------------------
    'データがなかった場合 (フィールド名がある場合)
    If lngLastRow = 1 Then
        MsgBox "該当データがありませんでした"

        Worksheets(Worksheets.Count).Select

        Application.DisplayAlerts = False
        ActiveWindow.SelectedSheets.Delete
        Application.DisplayAlerts = True
        
        Sheets(strMySheet).Select

        Exit Sub

    End If
    
'    'データがなかった場合 (フィールド名がない場合)
'    If lngLastRow = 1 And Cells(1).Value = Empty Then
'        MsgBox "該当データがありませんでした"
'
'        Worksheets(Worksheets.Count).Select
'
'        Application.DisplayAlerts = False
'        ActiveWindow.SelectedSheets.Delete
'        Application.DisplayAlerts = True
'
'        Sheets(strMySheet).Select
'
'        Exit Sub
'
'    End If
'-----------------------------------------------
    
    Application.DisplayAlerts = False

    'CSVファイルの作成
    ActiveSheet.Copy
    ActiveSheet.SaveAs Filename:=txtTMPNAME, FileFormat:=xlCSV, CreateBackup:=False
    ActiveWorkbook.Close
    
    '追加したシートを削除
    Worksheets(Worksheets.Count).Select
    ActiveWindow.SelectedSheets.Delete
    
    Application.DisplayAlerts = True
    
    Sheets(strMySheet).Select
    MsgBox "作成完了しました", vbInformation

End Sub


 ↓ facebook のフォローで応援してください。お願いします。



Microsoft Office ブログランキングへ