VBAの備忘録 隠しシートに値を書込み、別ブックにしてデスクトップに保存

【流れ】
ブランクフォームとして隠しているシートに値を書込み、別ブックにしてデスクトップに保存する。

呼び出し元シートのプロシージャ内の一部

　　
    Application.ScreenUpdating = False      '-------画面更新停止(パラパラ画面が変わるので、これ重要!!!)

    '事前に隠しシートに値を書込む=================================================
　　Dim ws As Worksheet
　　Set ws = ThisWorkbook.Worksheets("隠しシート名")   '←書込み先

    '
    '   省略
    '

    'ファイル出力=================================================================
    'デスクトップにファイルを生成する
    
    'デスクトップのパスを調べる------------------------------------
    Dim Path As String
    Dim フルPath As String
    Dim WSH As Variant
    Set WSH = CreateObject("Wscript.Shell")
    Path = WSH.SpecialFolders("Desktop") & "\"

    'ファイル名の確定----------------------------------------------
    Dim ファイル名 As String
    ファイル名 = "新しいファイル名称_" & Format(Now, "yyyy年mm月dd日") & ".xlsx"

    MsgBox ("不動在庫一覧表をデスクトップに出力します。" & vbCrLf & "　パス⇒　" & Path & vbCrLf & "　ファイル名⇒　" & ファイル名)
    

    '!!!!!!!!!!!!!!!!ファイルの事前チェック!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    '①ファイルは存在するのか？
    If Dir(Path & ファイル名) = "" Then

        'MsgBox ("ファイルは存在しません。")

    Else
        'MsgBox ("ファイルが存在します。" & vbCrLf & "引き続き、開かれてるかをチェックします。")
        '次に開かれてるかをチェック
        '②ファイルは開いているか？
        If IsBookOpened(Path & ファイル名) = True Then
            
            MsgBox (ファイル名 & " が開かれています。このファイルを閉じて再度ボタンを押してください。")
            ThisWorkbook.Worksheets("不動").Activate
            Exit Sub
            
        Else
            'MsgBox ("ファイルは開かれていません。")
        End If
        
    End If

    'MsgBox ("ファイルの事前チェック完了。")

    
    ws.Visible = xlSheetVisible　　　　'【重要】隠したままでは、コピーできない！
    ws.Copy
    
    ActiveWorkbook.ActiveSheet.Name = "新シート名"    'シート名を変更する【重要】.CopyしたシートがActiveになっている


      '!!!!!!!!!!!!!!!!ファイル出力!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
    '【参考】http://officetanaka.net/excel/vba/file/file09.htm
    
    Dim 出力結果 As String
    出力結果 = "NG"
    
    Dim フルパス As String, re As Long
    If ActiveWorkbook.Path = "" Then
        ''まだ保存されたことがないブック
        'MsgBox ("まだ保存されたことがないブック!!!")
        フルパス = Path & ファイル名
        
        If Dir(フルパス) <> "" Then
            'MsgBox ("既存ファイル有る!!!")
            re = MsgBox("この場所に" & vbCrLf & "  " & ファイル名 & vbCrLf & _
                        "という名前のファイルが既にあります。置き換えますか？", _
                        vbInformation + vbYesNoCancel + vbDefaultButton2)
                        
            If re = vbYes Then

                Application.DisplayAlerts = False   '【!!!ポイント!!!】保存しますかのメッセージを出さない。
                On Error Resume Next '【!!!ポイント!!!】エラー無視!!!
                
                ActiveWorkbook.SaveAs _
                FileName:=Path & ファイル名, _
                FileFormat:=xlOpenXMLWorkbook
                
                On Err GoTo Err  'エラー対策戻し
                Application.DisplayAlerts = True
                
                出力結果 = "OK"

            End If
        Else
            'MsgBox ("既存ファイル無し!!!")
            ActiveWorkbook.SaveAs _
                FileName:=Path & ファイル名, _
                FileFormat:=xlOpenXMLWorkbook
                 
            出力結果 = "OK"

        End If
    Else
        '【注意】今回のケースではここには来ないが残しておく。
        'すでに保存されたブック
        ActiveWorkbook.SaveAs _
            FileName:=Path & ファイル名, _
            FileFormat:=xlOpenXMLWorkbook
    End If


    Application.DisplayAlerts = False   '【!!!重要!!!】保存しますかのメッセージを出さない。
    ActiveWorkbook.Close
    Application.DisplayAlerts = True　　'【!!!重要!!!】戻しておくっ。
    

    ws.Visible = xlSheetVeryHidden　　　'隠しファイルを隠した状態に戻す。
    
    ThisWorkbook.Worksheets("呼び出し元シート").Activate　'呼び出し元のシートをアクティブに。
    
    Set ws = Nothing　　　　　　　　　　　'最後の始末もお忘れなく。

    Application.ScreenUpdating = True   '-----------------やっとここで、画面更新再開！

そしてファイルが開いているかチェックするファンクションは…

Function IsBookOpened(フルパス As String) As Boolean
    On Error Resume Next
    
    '【注意】ブックが存在しない場合、ファイルを中途半端に作成してしまう。
    '　　　だから、事前にブックが存在しないことを確認して使う
    
    
    ' 保存済みのブックか判定
    Open フルパス For Append As #1
    Close #1
    
    If Err.Number > 0 Then
        ' 既に開かれている場合
        IsBookOpened = True
    Else
        ' 開かれていない場合
        IsBookOpened = False
    End If
End Function

　これだと別エクセルで開かれていると判らないのでボツ↓

Function IsBookOpened2(ファイル名 As String) As Boolean
    
    '【ボツ】これだと、他のエクセルで開かれていると判別できない
    
    Dim myChkBook As Workbook

    On Error GoTo Err
    Set myChkBook = Workbooks(ファイル名)

    'MsgBox "開かれています。"
    ファイルは開いているか = True
    Exit Function
    
Err:
    'MsgBox "開かれていません。"
    ファイルは開いているか = False
End Function