| |
こんばんは。
>こちらで教わり、マクロを実際に動かしてみたのですが、
>D:\miwa\【QZ】\DB\営業所\当年\1.国内\商品別\Aという
>様な階層になっており、実はDBフォルダの下には
>30個位のフォルダがあります。
>DBフォルダ以下全てのフォルダの中にある
>エクセルファイルの全シートの文字列を一気に置換したいのです。
>一つ一つフォルダの中にマクロブックをおいてやってみたのですが、
>かなり時間のかかる操作で、これでは終わらない(ToT)/~~~
>どの部分を直せば、よいのでしょうか？
見せていただいたコードは正常に作動しているのですよね？
簡単にトレースしてみましたが、
前処理
> strPath = ThisWorkbook.Path
> strFileName = Dir(ThisWorkbook.Path & "\*.xls")
ループ処理
> Do Until strFileName = ""
・
・
> Loop
終了処理
この事例では何もしない
という情報処理の基本的な構造になっています。
私もプログラムはこの形式になるように作るようにしています。
この事例では、Dir関数の存在がこの形式にするためには
不可欠な道具になっています。
しかし、指定されたフォルダの下の階層までのファイル検索となると
DIR関数だけでは実現できませんね。
でも、上記の形式（前処理、ループ処理、終了処理）を維持し、
Dir関数の代わりに
指定されたフォルダの下の階層まで検索する関数があれば、
提示されたコードを殆ど変更することなしに使用できますよね？
ということでなるべく元のコードを変更しないというコンセプトで
標準モジュールに
'========================================================
Sub 置換()
Dim ws As Worksheet
Dim wb As Workbook
Dim strFileName As String
Dim nm As Variant
'ブックが格納されているフォルダ（マクロブックと同じフォルダの場合）
If fold_open("D:\miwa\【QZ】\DB", "*.xls", False) = 0 Then
strFileName = fold_get
Do Until strFileName = ""
nm = Split(strFileName, "\")
If nm(UBound(nm)) <> ThisWorkbook.Name Then
'ブックを開く
Set wb = Workbooks.Open(strFileName)
'開いたブックをのすべてのシートをひとつずつアクティブにする
For Each ws In Worksheets
ws.Activate
Cells.Replace What:="2007年", Replacement:="翌年", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Cells.Replace What:="2006年", Replacement:="当年", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Next
'開いたブックを上書き保存する
wb.Save
'開いたブックを上書き保存しない
'wb.Saved = True
'開いたブックを閉じる
wb.Close
End If
strFileName = fold_get
Loop
End If
Call fold_close
End Sub
別の標準モジュールに以前このサイトのご質問で使った・・・、
'=================================================================
Private f_cnt As Long
Private f_path() As String
Private f_idx As Long
'====================================================================
Function fold_open(ByVal stDir As String, ByVal f_file As String, ByVal 捜索階層) As Long
'指定されたパスを捜索開始パスとして、指定されたファイルを捜索します
'尚、ファイル名の大文字・小文字は区別しません
'input : stDir-----捜索開始パス
' f_file----捜索ファイル名
' 捜索階層---False-----開始パスから全ての階層を捜索する
' 数値（>0）-開始パスから指定された階層のフォルダを捜索する（1の場合は､開始パスのみ）
'output : fold_open 0--------条件に合ったファイルが1つ以上見つかった
' 1--------条件に合ったファイルは見つからない
' その他---以上終了（エラーコード）
On Error Resume Next
Dim fso As Object
Dim f_fld As Object
fold_open = 0
Erase f_path()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f_fld = fso.GetFolder(stDir)
If Err.Number <> 0 Then
fold_open = Err.Number
Else
f_cnt = 0
Call fold_search(f_fld, f_file, 捜索階層)
If f_cnt <= 0 Then
fold_open = 1
Else
f_idx = 1
End If
End If
Set fso = Nothing
Set f_fld = Nothing
End Function
'========================================================================
Sub fold_search(ByVal f_fld As Object, ByVal f_file As String, ByVal 捜索階層)
Dim sfld As Object
Dim fl As Object
Dim ret As Boolean
For Each fl In f_fld.Files
If UCase(fl.Name) Like UCase(f_file) Then
ReDim Preserve f_path(1 To f_cnt + 1)
f_path(f_cnt + 1) = fl.Path
f_cnt = f_cnt + 1
End If
Next fl
If VarType(捜索階層) = vbBoolean Then
ret = True
Else
If 捜索階層 - 1 > 0 Then
捜索階層 = 捜索階層 - 1
ret = True
Else
ret = flase
End If
End If
If ret = True Then
For Each sfld In f_fld.SubFolders
Call fold_search(sfld, f_file, 捜索階層)
Next
End If
End Sub
'======================================================================
Function fold_get() As String
'fold_openが0だった場合､順次見つかったファイルのフルパスを取り出す
'output: fold_get-----条件に合ったファイルのフルパス。空白の場合は、データの終わり
If f_idx > UBound(f_path()) Then
fold_get = ""
Else
fold_get = f_path(f_idx)
f_idx = f_idx + 1
End If
End Function
'========================================================================
Sub fold_close()
'ファイル捜索のクローズ処理
Erase f_path
f_idx = 0
f_cnt = 0
End Sub
として、置換を実行してみてください。
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
- 06/10/30(月) 10:15 -
