« ◆自動ログインツール(ネット自動操作ツールバージョンアップ) | トップページ | ◆Excel VBA(定型フォーマットのExcelを一気に開いて複数作成するマクロ(第1回)) »

2007年5月21日 (月)

◆Excel VBA(複数の定型フォーマットブックを開いて一覧表を作るマクロ(第2回))

第1回からだいぶ間隔が開いてしまいましたが第2回です。
少しおさらいをすると、各部門から申請された複数の申請書を一覧化しようというものでした。詳しくはこちらをご覧ください。http://peiyorin.cocolog-nifty.com/blog/2007/05/excel_vba_e3dc.html

前回の仕様をマクロにしたものが以下です。

'申請書フォーマット
Const f_部署cel As String = "C2"
Const f_申請者cel As String = "C4"
Const f_承認者cel As String = "C6"
Const f_承認日cel As String = "C8"
Const f_機能名cel As String = "C10"
Const f_依頼事項cel As String = "C12"

'申請書一覧
Const cStRow As Integer = 3
Const 部署col As Integer = 2
Const 申請者col As Integer = 3
Const 承認者col As Integer = 4
Const 承認日col As Integer = 5
Const 機能名col As Integer = 6
Const 依頼事項col As Integer = 7
Const 処理日col As Integer = 8
Const ファイル名col As Integer = 9
Const 更新日col As Integer = 10

Sub ファイル取り込み()
    Const cDefPath As String = "c:\work"
    Const cMyWs As String = "申請一覧"
   
    Set oMyWs = ThisWorkbook.Sheets(cMyWs)
   
    'クリア確認
    If vbYes = MsgBox("一覧をクリアしますか?", vbYesNo + vbQuestion, "クリア確認") Then
        lLastRow = oMyWs.Cells(65500, 部署col).End(xlUp).Row + 1
        oMyWs.Range(oMyWs.Cells(cStRow, 部署col), oMyWs.Cells(lLastRow, 更新日col)).ClearContents
    End If
   
    'フォルダ指定
    ChDrive Left(cDefPath, 1)
    ChDir cDefPath
    FileDir = Application.GetSaveAsFilename("DUMMY", "Excelファイル(*.xls),*.xls", , "■■■ フォルダ指定 ■■■")
    If FileDir = "False" Or FileDir = "FALSE" Then Exit Sub
    FileDir = Mid(FileDir, 1, InStrRev(FileDir, "\") - 1)
   
   
    'ファイル情報取り込み
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set f = fs.getFolder(FileDir)
   
    For Each oF In f.Files
        If Not (IsNumeric(Left(oF.Name, 8))) Then GoTo next_oF
        If Not (oF.Name Like "*.xls") Then GoTo next_oF
       
        Workbooks.Open oF.Name, ReadOnly:=True
        Set oActWs = ActiveWorkbook.Sheets(1)
       
        lLastRow = oMyWs.Cells(65500, 部署col).End(xlUp).Row + 1
        oMyWs.Cells(lLastRow, 部署col).Value = oActWs.Range(f_部署cel).Value
        oMyWs.Cells(lLastRow, 申請者col).Value = oActWs.Range(f_申請者cel).Value
        oMyWs.Cells(lLastRow, 承認者col).Value = oActWs.Range(f_承認者cel).Value
        oMyWs.Cells(lLastRow, 承認日col).Value = oActWs.Range(f_承認日cel).Value
        oMyWs.Cells(lLastRow, 機能名col).Value = oActWs.Range(f_機能名cel).Value
        oMyWs.Cells(lLastRow, 依頼事項col).Value = oActWs.Range(f_依頼事項cel).Value
        oMyWs.Cells(lLastRow, 処理日col).Value = Now()
        oMyWs.Cells(lLastRow, ファイル名col).Value = oF.Name
        oMyWs.Cells(lLastRow, 更新日col).Value = oF.DateLastModified
            
        ActiveWorkbook.Close
       
next_oF:
    Next

    Set fs = Nothing
    Set f = Nothing
    Set oF = Nothing
    Set oActWs = Nothing
    Set oMyWs = Nothing
   
End Sub

ま、あくまでも一例であり、ロジックや実現手段はいろいろあるかと思います。
一応できるだけ汎用的にしたつもりです。それでは解説していきます。
まず、Constで定型フォーマットの入力セル位置を定義しています。ここは皆さんが使用されている定型フォーマットにあわせて修正してくださいね。次に申請書内容を一覧化する申請一覧の列番号を定義しています。後ほど、このマクロを実装した申請一覧をアップロードしますのでそちらをご覧になった方が一目瞭然でしょう。
さて、ロジック部分ですが、まず、マクロを実行する際に、申請一覧を一旦クリアするかどうかメッセージを表示させています。
次に、申請書が格納されているフォルダを指定するダイアログを表示します。実行するとわかるのですが、Application.GetSaveAsFilenameを流用しているのでファイル名に”DUMMY”がデフォルト表示されますが気にしないでください。ここの目的は格納先フォルダ名を取得することです。
次に、Set fs = CreateObject("Scripting.FileSystemObject")でFileSystemObjectオブジェクトを生成します。fsに対してGetFolderを実行して、指定されたフォルダ配下のファイルを全て取得します。For Each oF In f.Filesで取得したファイルに対して処理を繰り返していきます。まず、申請書ファイル名の規定であるyyyymmddのExcelファイル以外は処理を飛ばすように条件判断しています。先頭8文字が数字かという条件にしています。(日付か?というロジックが思い浮かばなくてごまかしています)
次に、条件に合致したファイルを開き、開いたExcelブックをoActWsオブジェクトとしています。申請一覧の最終行lLastRowを求め、申請書の入力項目を申請書一覧に貼り付け、開いた申請書を閉じて1件分終了という具合です。
申請書の入力項目以外に、管理情報として処理日、ファイル名、ファイル更新日も一覧化しています。
これで申請書を全て一覧化することができました。
申請書フォーマットと申請書一覧をカスタマイズすれば応用が利くでしょう。お試しください。

申請書一覧と申請書サンプル2ファイルを同梱しました。動作を確認してみてください。右クリックで「対象をファイルに保存」でダウンロードしてください。

sinsei_sample.EXE

次回は、申請者側の立場から、申請書を一気に複数生成するマクロについて書いてみたいと思います。

« ◆自動ログインツール(ネット自動操作ツールバージョンアップ) | トップページ | ◆Excel VBA(定型フォーマットのExcelを一気に開いて複数作成するマクロ(第1回)) »

パソコン・インターネット」カテゴリの記事

コメント

コメントを書く

(ウェブ上には掲載しません)

« ◆自動ログインツール(ネット自動操作ツールバージョンアップ) | トップページ | ◆Excel VBA(定型フォーマットのExcelを一気に開いて複数作成するマクロ(第1回)) »