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

タイトル ： 既存のExcelファイルにシートを追加
投稿日： 2008/05/01(Thu) 20:03
投稿者： べた
VBからExcelを起動し、データベースから取得した値を設定しています。

ファイルが存在しない場合は、新規作成し、既存のファイルが存在する
場合は、既存のファイルを開き、シートを新しく追加して設定します。

新規作成は、上手く動いているみたいです。
ここで、追加するファイルが既に存在する場合、
また、追加するシートが必ず一番左側に作られてしまいます。
存在しているシートの一番後（一番右側）に作りたいのです。

また、同じシートが存在した場合、シートをコピーしたようなかたち、
つまり「(2)、(3)・・・」をつけて作成したいのです。

以下の様に作ってみたのですが、どうしても、一番右側にシートが
作られてしまいますし、上手く保存ができません。

どうすればよいか教えてください。
また、新規作成についてもどこかおかしいところがありましたら
ご指摘下さい。


--- ソースコード（抜粋）

Private Function Excel_set(objDs As Object,Sheet_name As String) As Boolean
    Dim Fso As FileSystemObject
    Dim xlApp   As Excel.Application
    Dim xlBook  As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim FileDir As String
    Dim strToday As String
    Dim strExcelFile As String
    Dim strExcelSheet As String
    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 = Sheet_name

    Set xlApp = CreateObject("Excel.Application")
    If Fso.FileExists(strExcelFile) = True Then
        Set xlBook = xlApp.Workbooks.Open(strExcelFile)
        Set xlSheet = xlBook.Worksheets.Add
        Set xlSheet = xlBook.Worksheets(xlBook.Worksheets.Count)
    Else
        Set xlBook = xlApp.Workbooks.Add
        Set xlSheet = xlBook.Worksheets(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

    '書式設定

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

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