VBからExcelに出力する際に切り替えメッセージが表示されるのは？
いつもお世話になります。
昨日、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
| ツイート |  |