Excel VBA質問箱 IV

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

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


66786 / 76734 ←次へ | 前へ→

【14507】Re:Application.Quit について
質問  nao  - 04/5/31(月) 12:36 -

引用なし
パスワード
   返答ありがとうございます。
書いていませんでしたが、これはVBから
EXCEL.exeを起動してから、マクロを立ち上げています。
ソースは以下の通りです。
少し長いですが、申し訳ありません。
変数宣言をして、制御した場合ですが、もちろん
グローバル変数にしています。

Sub CsvHozon()

  On Error GoTo ERR_EXIT
    
  Application.ScreenUpdating = False   '処理画面非表示
  Application.DisplayAlerts = False    '警告メッセージ非表示
  Application.EnableEvents = False    'イベント発生させない

  If RES = vbYes Then
    
    fileMei = wsFileB
    
    prgSeq = "0140"
    If wsKakukbn = "EXCEL" Then
      ChDir wsPass
      myFName = Application.GetSaveAsFilename(fileMei, "CSVファイル       End If
    
    prgSeq = "0160"
    If myFName <> "False" Then
  
      prgSeq = "0180"
      Len1 = Len(myFName)
      'パス + ファイル名(拡張子なし)
      NmyFName = Mid(myFName, 1, Len1 - 4)
      '拡張子
      KmyFName = Mid(myFName, Len1 - 3, Len1)
      
      Len2 = Len(NmyFName)
      'Len2 = LenB(StrConv(myFName, vbFromUnicode))
      
      '最後の\の位置を確認
      prgSeq = "0200"
      For lLoopCnt = 1 To Len1 - 4
        If Mid(myFName, lLoopCnt, 1) = "\" Then
          wkIti = lLoopCnt
        End If
      Next lLoopCnt
    
      '実際に入力されたファイル名を取得
      prgSeq = "0220"
      fileMei = Mid(NmyFName, wkIti + 1, 100)
      
      '新規bookOpen
      prgSeq = "0240"
      Workbooks.Add
    
      'シートの数
      prgSeq = "0260"
      shtCnt = ActiveWorkbook.Worksheets.Count
    
      'シート1削除
      If ActiveWorkbook.Worksheets.Count > 1 Then
      
        'シート1削除
        prgSeq = "0280"
        ActiveWorkbook.Worksheets(1).Select
        ActiveWindow.SelectedSheets.Delete
    
        '新規bookの名前変更
        prgSeq = "0300"
        ActiveWorkbook.SaveAs Filename:=NmyFName & "temp2" & KmyFName, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
    
        '新規エクセルにシートコピー
        prgSeq = "0320"
        ThisWorkbook.Worksheets(1).Copy Before:=Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1)
        
        'シート削除
        prgSeq = "0340"
        For lLoopCnt = 2 To shtCnt
          'Workbooks(fileMei & "temp2" & KmyFName).Worksheets(lLoopCnt).Delete
          Workbooks(fileMei & "temp2" & KmyFName).Worksheets("Sheet" & lLoopCnt).Delete
        Next lLoopCnt
      
      Else
        'シート1の名称変更
        prgSeq = "0360"
        ActiveWorkbook.Worksheets(1).Select
        ActiveWorkbook.Sheets.Add
        ActiveWorkbook.Worksheets(1).Select
        ActiveWorkbook.Worksheets(1).Delete
      
        '新規bookの名前変更
        prgSeq = "0380"
        ActiveWorkbook.SaveAs Filename:=NmyFName & "temp2" & KmyFName, FileFormat:= _
        xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
        , CreateBackup:=False
    
        '新規エクセルにシートコピー
        prgSeq = "0400"
        ThisWorkbook.Worksheets(1).Copy Before:=Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1)
    
        Workbooks(fileMei & "temp2" & KmyFName).Worksheets(2).Select
        Workbooks(fileMei & "temp2" & KmyFName).Worksheets(2).Delete
    
      End If
    
      '画面のボタン削除
      prgSeq = "0420"
      Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton1").Delete
      Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton2").Delete
      Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton3").Delete
      Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).OLEObjects("CommandButton4").Delete
      
      '画面のヘッダー削除
      prgSeq = "0440"
      Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).Rows("1" & ":" & pgHdg - 1).Select
      Selection.Delete Shift:=xlUp
      Workbooks(fileMei & "temp2" & KmyFName).Worksheets(1).Range("A" & pgHdg).Select
  
      'マクロは削除して保存
      With Workbooks(fileMei & "temp2" & KmyFName).VBProject
        For Each VBC In .VBComponents
         Select Case VBC.Type
           Case 1, 2, 3
            .VBComponents.Remove VBC
           Case 100
            With VBC.CodeModule
              .Deletelines 1, .Countoflines
            End With
         End Select
        Next
      End With
      
      'エラーだった場合色を消す
      Cells.Select
      Selection.Interior.ColorIndex = xlNone
      Range("A1").Select
      
      'ウインドウ枠の固定を解除
      prgSeq = "0460"
      ActiveWindow.FreezePanes = False
      
      prgSeq = "0480"
      If KmyFName = ".xls" _
      Or KmyFName = ".XLS" Then
        Workbooks(fileMei & "temp2" & KmyFName).Save
        Workbooks(fileMei & "temp2" & KmyFName).Close
      Else
        Workbooks(fileMei & "temp2" & KmyFName).SaveAs Filename:=NmyFName & "temp2" & KmyFName, FileFormat _
        :=xlCSV, CreateBackup:=False
        Workbooks(fileMei & "temp2" & KmyFName).Close
      End If

      '上書き保存かどうかの確認
      '上書き保存でない場合
      If wsExcel <> NmyFName & KmyFName Then
      
        '名称変更 (temp名、削除)
        prgSeq = "0500"
        strFile = Dir(NmyFName & KmyFName)
        If strFile <> "" Then
    
          Kill (NmyFName & KmyFName)
    
        End If
      
        prgSeq = "0520"
        Name NmyFName & "temp2" & KmyFName As NmyFName & KmyFName
      
        'tempファイル名変更
        prgSeq = "0540"
        strFile = Dir(wsBackupPass & wsFileA & wsKakutyo)
        strFileB = Dir(wsBackupPass & wsFileA & "temp" & wsKakutyo)
    
        prgSeq = "0560"
        If strFile = "" _
        And strFileB <> "" Then
            
          Name wsBackupPass & wsFileA & "temp" & wsKakutyo As wsBackupPass & wsFileA & wsKakutyo
          
        End If
      
      '上書き保存の場合
      Else
      
        prgSeq = "0580"
        strFile = Dir(wsBackupPass & wsFileA & wsKakutyo)
        strFileB = Dir(wsBackupPass & wsFileA & "temp" & wsKakutyo)
      
        If strFile <> "" Then
    
          Kill (wsBackupPass & wsFileA & wsKakutyo)
  
        End If
    
        prgSeq = "0500"
        Name NmyFName & "temp2" & KmyFName As wsBackupPass & wsFileA & wsKakutyo
          
      End If
      
      Application.EnableEvents = False    'イベント発生させない
      'ThisWorkbook.Close
      'ここです。
      Application.Quit
    
    End If
  
  End If

  Range("A" & pgHdg).Select
  GoTo NORMAL_EXIT

''**********************************************************************
''エラールーチン設定
''**********************************************************************

ERR_EXIT:
  
  'temp元に戻す
   strFile = Dir(wsBackupPass & wsFileA & wsKakutyo)
   strFileB = Dir(wsBackupPass & wsFileA & "temp" & wsKakutyo)
      
   If strFile = "" _
   And strFileB <> "" Then
      
     Name wsBackupPass & wsFileA & "temp" & wsKakutyo As wsBackupPass & wsFileA & wsKakutyo
      
   End If
  
  retErrMsg = ""
  retErrMsg = retErrMsg & "  VB_Error Number:" & Err.Number & vbCrLf
  retErrMsg = retErrMsg & "  VB_Error Description:" & Err.Description & " " & _
        "エラーファイル名 : 単品マクロ、 " & "エラー箇所 : " & "(CsvHozon)、" & prgSeq & " " & vbCrLf
  MsgBox retErrMsg

  ThisWorkbook.Close

''**********************************************************************
''正常終了
''**********************************************************************
  
NORMAL_EXIT:
  
  Application.ScreenUpdating = True   '処理画面表示
  Application.DisplayAlerts = True    '警告メッセージ表示
  Application.EnableEvents = True    'イベント再発生
  
  'Excel を閉じる
  'Application.Quit

End Sub
1 hits

【14501】Application.Quit について nao 04/5/30(日) 21:05 質問
【14504】Re:Application.Quit について つん 04/5/31(月) 10:02 発言
【14505】Re:Application.Quit について ichinose 04/5/31(月) 10:43 発言
【14507】Re:Application.Quit について nao 04/5/31(月) 12:36 質問

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