tagCANDY CGI VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
VBレスキュー(花ちゃん)の Visual Basic 6.0用 掲示板
[ツリー表示へ]　 [ワード検索]　 [Home]

タイトル ： 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へのデータの設定）を行ったのですが、２回以降は、エラーが発生して
してしまいます。

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
-----
- 関連一覧ツリー （ をクリックするとツリー全体を一括表示します）

古いスレッドにレスはつけられません。