Help us understand the problem. What is going on with this article?

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

More than 1 year has passed since last update.

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

呼び出し元シートのプロシージャ内の一部
  
    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

Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away