| 投稿日 | ： 2005/02/04(Fri) 18:45 |
| 投稿者 | ： こう |
| ＵＲＬ | ： |
| タイトル | ： Re^6: DoEventsを常に取得出来る方法はありますでしょうか？ |
ご返事有難う御座いました。m(_ _)m
以下のコードです
' ************************************************************
' 予算ファイルを開いて合計ファイルにマージして行く処理
'
' 引数(IN): strDirPath EXCELファイルの保存先パス
' 引数(IN): strCreatPath EXCELの保存先パス
' 引数(OUT): arStrFileList() 開くEXCELファイル名格納配列
' 戻り値： Boolean true = 正常、false = 異常
' ************************************************************
Private Function MergeExcel(ByVal strDirPath As String, _
ByVal strCreatPath As String, _
ByRef arStrFileList() As String) As Boolean
On Error GoTo ErrHandler:
Dim xlTotalBook As Excel.Workbook '作業する合計Bookの宣言
Dim xlTotalSheet As Excel.Worksheet '作業する合計シートの宣言
Dim xlSitenBook As Excel.Workbook '作業するコピーBookの宣言
Dim xlSitenSheet As Excel.Worksheet '作業するコピーシートの宣言
Dim xlApp As Excel.Application
Dim iProgressBarCount As Integer 'ProgressBarカウント
Dim strFileName As String 'ファイル名
Dim iFileCount As Integer 'For文カウント
Dim i As Integer 'For文カウント
Dim iExcelFileCount As Integer '予算ファイルOpenカウント
Dim blnRet As Boolean
' ReesizeTimer.Interval = 10
' ReesizeTimer.Enabled = True
MergeExcel = True
'Excelを開く
Set xlApp = CreateObject("excel.Application")
'合計用ブックを新規作成する
Set xlTotalBook = xlApp.Workbooks.Add
xlApp.DisplayAlerts = False '上書き保存しますか？のメッセージを出さない
Set xlTotalSheet = xlTotalBook.Worksheets("sheet1")
For iFileCount = 0 To エクセルファイル数
blnRet = True
'.xlsの拡張子を取りファイル名を取得
strFileName = Replace(arStrFileList(iFileCount), ".xls", "")
' ファイルを開いてからのチェック
If blnRet Then
'ファイルを開く
Set xlSitenBook = xlApp.Workbooks.Open(strDirPath & "\" & arStrFileList
(iFileCount))
'シートをセットする
Set xlSitenSheet = xlSitenBook.Worksheets(strFileName)
If blnRet Then
'支店シートを合計シートにコピー
iExcelFileCount = iExcelFileCount + 1
xlSitenSheet.Copy Before:=xlTotalBook.Worksheets(iExcelFileCount)
End If
'終了処理
xlSitenBook.Close
Set xlSitenSheet = Nothing
Set xlSitenBook = Nothing
End If
'画面の最小化制御用にたまったイベントを実行させる
DoEvents
Next
こんな感じです。
宜しくお願い致します。