エクセルマクロでご教示ください

質問

エクセルで作られたデータファイルに対し、ある操作を施して上書き保存するというマクロを作りました。
そのマクロを走らせるとファイル名を聞いてきまして、そこでファイル名を入力してやれば、ある操作を施したあと
自動的に上書き保存までしてくれるのですが、対象ファイルが複数個あると、ひとつ実行したあとまたひとつ
ファイル名を入れて、またそれが終ったら次のファイル名を・・・というように、ひとつひとつ実行しなければならない
というのが現状です。
これを次のように改良したいのですが、どうすればいいのでしょうか？

１．マクロを立ち上げる。
２．処理する複数のファイルが入っている「フォルダ」を選ぶ。
　（一覧表示のウィンドウが出てきて、その中で「フォルダ」を選ぶ）
３．そのフォルダの中に入っているエクセルファイル全てに対し、既に作成済みのマクロを順次実行する。

というものです。

よろしくお願いします。

回答No.2

KenKen_SP · ベストアンサー

Module1とModule2にそれぞれコピー＆ペーストしてお使い下さい。

・Module1 は「フォルダ選択ダイアログ」を実現するコード
　おまけでネットワークドライブ名をUNCに変換する関数をつけました。
　汎用的に他のプログラムでも使えると思います。

・Module2 は今回のご質問のメイン部分です。
　FileSearch は極まれに２重検索することがありますので、処理する
　ファイルの順番が不問の場合は、Dir 関数の方が良いかもしれません。

'■■■■■　【 Module1 にコピー＆ペースト 】　■■■■■■■■■■■

'フォルダ選択ダイアログ

Option Explicit

'API宣言
Declare Function SHBrowseForFolder Lib "shell32.dll" ( _
　　lpbi As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32" ( _
　　ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function WNetGetConnection Lib "mpr.dll" Alias "WNetGetConnectionA" ( _
　　ByVal lpszLocalName As String, _
　　ByVal lpszRemoteName As String, _
　　cbRemoteName As Long) As Long
Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)

'BROWSEINFO構造体
Type BROWSEINFO
　　hwndOwner　　　As Long
　　pidlRoot　　　 As Long
　　pszDisplayName As String
　　lpszTitle　　　As String
　　ulFlags　　　　As Integer
　　lpfn　　　　　 As Long
　　lParam　　　　 As Long
　　iImage　　　　 As Integer
End Type

Private Const CSIDL_DESKTOP = &H0　　　　'デスクトップ
Private Const BIF_RETURNONLYFSDIRS = &H1 'フォルダのみ
Private Const MAX_PATH = 256　　　　　　 'パス文字列最大長

'フォルダ選択ダイアログ表示
Public Function BrowseForFolder( _
　　Optional strCaption As String = "フォルダを指定して下さい", _
　　Optional ConvertUNC As Boolean = False) As String
　　Dim typBrowserInfo As BROWSEINFO
　　Dim lngRet　　　　 As Long
　　Dim strFullPath　　As String
　　With typBrowserInfo
　　　　.ulFlags = BIF_RETURNONLYFSDIRS
　　　　.lpszTitle = strCaption
　　　　.pidlRoot = CSIDL_DESKTOP
　　End With
　　lngRet = SHBrowseForFolder(typBrowserInfo)
　　If lngRet >= 0 Then
　　　　strFullPath = String$(MAX_PATH, vbNullChar)
　　　　SHGetPathFromIDList lngRet, strFullPath
　　　　CoTaskMemFree lngRet 'メモリ解放
　　　　BrowseForFolder = _
　　　　　　Left$(strFullPath, InStr(strFullPath, vbNullChar) - 1)
　　　　If ConvertUNC Then
　　　　　　Call ConvUNC(BrowseForFolder)
　　　　End If
　　Else
　　　　BrowseForFolder = vbNullString
　　End If
End Function

'UNC変換
Private Sub ConvUNC(ByRef strFullPath As String)
　　Dim strDRV As String
　　Dim strBuf As String * MAX_PATH
　　On Error GoTo ErrorHandler
　　strDRV = Left$(strFullPath, 2)
　　WNetGetConnection strDRV, strBuf, MAX_PATH
　　If InStr(1, strBuf, vbNullChar) > 1 Then
　　　　strFullPath = _
　　　　Left$(strBuf, InStr(1, strBuf, vbNullChar) - 1) _
　　　　& Mid$(strFullPath, 3)
　　End If
ErrorHandler:
　　Exit Sub
End Sub

'■■■■■　【 Module1 ここまで 】　■■■■■■■■■■■■■■■■

'■■■■■　【 Module2 にコピー＆ペースト 】　■■■■■■■■■■■

Sub フォルダ内全ブックの順次処理()

　　Dim strFolderPath As String
　　Dim WB As Workbook

　　'処理対象ファイル
　　Const TargetExt As String = "*.xls"

　　'フォルダを指定（ネットワークドライブ名はUNCに変換）
　　strFolderPath = BrowseForFolder(, True)
　　If strFolderPath = vbNullString Then
　　　　Exit Sub
　　Else
　　　　'パスセパレーター追加
　　　　strFolderPath = strFolderPath & Application.PathSeparator
　　End If

　　'指定フォルダ内の*.xls検索
　　strFoundFile = Dir(strFolderPath & TargetExt, vbNormal)
　　If strFoundFile = vbNullString Then
　　　　MsgBox "フォルダ内に " & TargetExt & _
　　　　　　　 " がありません", vbCritical, "中止"
　　　　Exit Sub
　　End If
　　Application.ScreenUpdating = False
　　Do While strFoundFile <> vbNullString
　　　　'ファイルオープン
　　　　Set WB = Workbooks.Open(strFolderPath & strFoundFile)

　　　　'ここに既に作成済みのマクロの処理を追加
　　　　MsgBox WB.Name '(EX)

　　　　'保存してファイルクローズ
　　　　Application.DisplayAlerts = False
　　　　　　WB.Close True
　　　　Application.DisplayAlerts = True
　　　　'再検索
　　　　strFoundFile = Dir
　　Loop

ExitProc:
　　Set WB = Nothing
　　Exit Sub
ErrorHandler:
　　Application.ScreenUpdating = True
　　MsgBox "Error Number: " & Err.Number & _
　　　　vbCrLf & Err.Description, _
　　　　vbCritical, "マクロ実行エラー"
　　Resume ExitProc
End Sub

'■■■■■　【 Module2 ここまで 】　■■■■■■■■■■■■■■■■

回答No.1

noname#109516

次のような方法では、マクロの一部ですがフォルダ内のファイル名を取得する方法です。

ChDrive "c:\"　’ドライブを指定
ChDir fp　’フォルダ名

Dim fno()
With Application.FileSearch
.NewSearch
.LookIn = fp
.Filename = "*.*"
.FileType = msoFileTypeExcelWorkbooks
If .Execute > 0 Then
For i = 1 To .Execute
fno(i) = .FoundFiles(i)

’作成済みマクロ

Next
End If
End With

この方法ではfpフォルダー内の全てのXlsファイル名を配列変数fno(i)にファイル名を取得します。