タイトル : Re^4: 既存のExcelファイルにシートを追加 投稿日 : 2008/05/02(Fri) 19:33 投稿者 : べた
ありがとうございます。 期待した動きをしました。 エクセルのヘルプまでは調べていませんでした。 VBのヘルプばかりで探していました。 「.Activate」、「.Select」の意味、使い方などもエクセルのヘルプでしょうか。 また、以下のでも動きました。 ----- xlBook.Worksheets.Add xlBook.ActiveSheet.Move After:=xlBook.Worksheets(xlBook.Worksheets.Count) Set xlSheet = xlBook.Worksheets(xlBook.Worksheets.Count) ----- 教えて頂いた、シートの追加で、画面を終了させずに、連続してシートの追加 (Excelへのデータの設定)を行ったのですが、2回以降は、エラーが発生して してしまいます。 Set xlBook = xlApp.Workbooks.Open(strExcelFile) Set xlSheet = xlBook.Worksheets.Add(after:=Worksheets(xlBook.Worksheets.Count)) 以下の様なエラーが発生します。 「アプリケーション定義またはオブジェクト定義のエラーです。」 また、タスクマネージャのプロセス欄からExcel.exe が消えてくれません。 どこがいけないのでしょうか。 ----- Private Function Excel_set(objDs As Object, obj_date As String) As Boolean Dim Fso As FileSystemObject Dim xlApp As Excel.Application Dim xlBook As Excel.Workbook Dim xlSheet As Excel.Worksheet Dim ws As Excel.Worksheet Dim FileDir As String Dim strToday As String Dim strExcelFile As String Dim strExcelSheet As String Dim tmpSheet As String Dim wsCnt As Integer Dim RowCnt As Integer Dim ColCnt As Integer Dim I As Integer On Error GoTo ErrHandle Excel_set = True FileDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") Set Fso = CreateObject("Scripting.FileSystemObject") If Fso.FolderExists(FileDir) = False Then Fso.CreateFolder FileDir End If strToday = Year(Date) & Format(Month(Date), "0#") & Format(Day(Date), "0#") strExcelFile = FileDir & "\" & "file_" & strToday & ".xls" strExcelSheet = obj_date Set xlApp = CreateObject("Excel.Application") If Fso.FileExists(strExcelFile) = True Then Set xlBook = xlApp.Workbooks.Open(strExcelFile) Set xlSheet = xlBook.Worksheets.Add(after:=Worksheets(xlBook.Worksheets.Count)) Else Set xlBook = xlApp.Workbooks.Add Set xlSheet = xlBook.Worksheets(1) End If wsCnt = 0 For Each ws In xlBook.Worksheets tmpSheet = ws.Name If InStrB(1, tmpSheet, strExcelSheet, -1) <> 0 Then wsCnt = wsCnt + 1 End If Next If wsCnt <> 0 Then strExcelSheet = strExcelSheet & " (" & wsCnt + 1 & ")" End If xlApp.Visible = False xlSheet.Activate DoEvents '見出し設定 xlSheet.Cells.NumberFormat = "@" ColCnt = 17 With xlSheet End With 'データ設定 I = 2 Do Until objDs.EOF With xlSheet End With I = I + 1 objDs.DbMoveNext Loop RowCnt = I - 1 '書式設定 With xlSheet End With xlApp.DisplayAlerts = False xlSheet.Name = strExcelSheet xlBook.SaveAs strExcelFile xlBook.Close xlApp.Quit If Fso.FileExists(strExcelFile) = False Then Excel_set = False Else MsgBox strExcelFile & Chr(13) & Chr(10) & "に作成しました。" End If Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing Set Fso = Nothing Exit Function ErrHandle: エラー処理 Excel_set = False xlBook.Close xlApp.Quit Set xlSheet = Nothing Set xlBook = Nothing Set xlApp = Nothing Set Fso = Nothing End Function ----- |