VBからExcelに出力する際に切り替えメッセージが表示されるのは？ (ID:108767)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

いつもお世話になります。
昨日、30000レコード×6列のCSVデータをExcelに吐き出そうとしたときに
以下のメッセージが表示されてしまいました。

│他のアプリケーションがサーバを使用しているため、この操作を│
      │完了できません。操作を続けるには、「切り替え」ボタンを選択│
      │して、他のアプリケーションを終了させて下さい。            │
      │      ［切り替え］    ［再試行］    ［キャンセル］        │
      
これは、何か作り側に問題があるのでしょうか？
いろいろやってみたのですが、どうもわかりません。
ソースを添付しますので、わかる方がいらっしゃったらアドバイスをお願い
いたします。

あと、このようなやり方では処理は遅いのでしょうか？
もっと早くExcelを表示させる方法はないのでしょうか？

Private Function ps_cmdExistExcelClk(p_strErr As String) As Integer
On Error GoTo Err_ps_cmdExistExcelClk

'---------------------------
                                                    '内部変数宣言
                                                    '---------------------------

Dim xlApp    As Excel.Application
    Dim xlBook   As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim w_Msg As String                             'エラーメッセージ取得
    Dim w_Msg2 As String                             'エラーメッセージ取得
    Dim w_RtnCD As Integer                          'エラー番号取得
    Dim w_RtnMsg As Integer
    Dim w_sFile As String
    Dim w_sFileName As String
    Dim w_lFileNo As Long
    Dim w_lCol As Long
    Dim w_lRow As Long
    Dim w_vLine As Variant
    Dim w_sLetter As Variant
    Dim w_iCount As Integer
    Dim w_sRep1 As String
    Dim w_sRep2 As String
    
                                                    '---------------------------
                                                    '処理
                                                    '---------------------------
    
    Set xlApp = CreateObject("Excel.Application")

'既存Excel場所をチェック
    w_sFile = Text2.Text
    
    If w_sFile = "" Then
        MsgBox "Excelのパスを入力してください", vbExclamation, "管理会計システム"
        Exit Function
    End If
    
    'Excelファイル存在チェック
    w_RtnCD = Pbc_FileExist(w_sFile, w_Msg)
    
    If w_RtnCD <> 0 Then
        Set xlSheet = Nothing
        Set xlBook = Nothing
        Set xlApp = Nothing
        
        If w_RtnCD = 999 Then
            w_RtnCD = Pbc_Message("C", "0010", w_Msg, w_RtnMsg, w_Msg2)
        ElseIf w_RtnCD = 599 Then
            w_RtnCD = Pbc_Message("C", "0010", w_Msg, w_RtnMsg, w_Msg2)
        ElseIf w_RtnCD = 107 Then
            w_RtnCD = Pbc_Message("C", "0010", "拡張子がありません", w_RtnMsg, w_Msg2)
        ElseIf w_RtnCD = 201 Then
            w_RtnCD = Pbc_Message("E", "0015", "CSV", w_RtnMsg, w_Msg2)
        End If
    
        If w_RtnCD <> 0 Then
            MsgBox MB_ErrMessage & w_Msg2, vbCritical, "管理会計システム"
        End If
        Exit Function
    End If

'この状態で起動した場合マクロの警告は表示されません。
    '以下の２行が（その１）との相違部分です
    Set xlBook = xlApp.Workbooks.Open(w_sFile)  'オープンするファイル名
    Set xlSheet = xlBook.Worksheets(1)     '最初のシートに書き込み
    '                    Worksheets(Sheet1等のシート名でも可)

'CSVファイルを拡張子を変更して読込
    w_sFileName = Text1.Text

If w_sFileName = "" Then
        MsgBox "CSVのパスを入力してください", vbExclamation, "管理会計システム"
        Exit Function
    End If

'CSVファイル存在チェック
    w_RtnCD = Pbc_FileExist(w_sFileName, w_Msg)
    
    If w_RtnCD <> 0 Then
        Set xlSheet = Nothing
        Set xlBook = Nothing
        Set xlApp = Nothing
        
        If w_RtnCD = 999 Then
            w_RtnCD = Pbc_Message("C", "0010", w_Msg, w_RtnMsg, w_Msg2)
        ElseIf w_RtnCD = 599 Then
            w_RtnCD = Pbc_Message("C", "0010", w_Msg, w_RtnMsg, w_Msg2)
        ElseIf w_RtnCD = 107 Then
            w_RtnCD = Pbc_Message("C", "0010", "拡張子がありません", w_RtnMsg, w_Msg2)
        ElseIf w_RtnCD = 201 Then
            w_RtnCD = Pbc_Message("E", "0015", "CSV", w_RtnMsg, w_Msg2)
        End If
    
        If w_RtnCD <> 0 Then
            MsgBox MB_ErrMessage & w_Msg2, vbCritical, "管理会計システム"
        End If
        Exit Function
    End If
        
    '空いているファイル番号を取得
    w_lFileNo = FreeFile
           
    w_lRow = 2
           
    'CSVファイルを開く
    Open w_sFileName For Input As #w_lFileNo
            
    Do Until EOF(w_lFileNo)
        '読込ファイルのレコードを取得する
        Line Input #w_lFileNo, w_sLetter
        
        '読み込んだ行を追加
        w_lRow = w_lRow + 1
            
        w_vLine = Split(w_sLetter, ",")
        w_lCol = 1
        For w_iCount = 0 To UBound(w_vLine)
            w_sRep1 = w_vLine(w_iCount)
            w_sRep2 = Replace(w_sRep1, """", "'", , 1)
            xlSheet.Cells(w_lRow, w_lCol) = Replace(w_sRep2, """", "")
            w_lCol = w_lCol + 1
        
            App.OleRequestPendingTimeout = 5000
            App.OleServerBusyRaiseError = False
        
        Next
    Loop
       
    xlApp.Cells.Select                  '入力データの幅にセルの幅を
    xlApp.Cells.EntireColumn.AutoFit    '広げる。

xlApp.Range("A2").Select            'ホームポジションに移動
    
    xlBook.Application.Visible = True
    
    'CSVファイルを閉じる
    Close w_lFileNo

Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing

Exit Function

Err_ps_cmdExistExcelClk:
    'オブジェクトを開放する
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Exit Function
End Function

←解決時は質問者本人がここをチェックしてください。

戻る