Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


6660 / 13644 ツリー ←次へ | 前へ→

【43875】文字列の置換2 miwa 06/10/27(金) 12:30 質問[未読]
【43880】Re:文字列の置換2 neptune 06/10/27(金) 15:04 発言[未読]
【43881】Re:文字列の置換2 ichinose 06/10/27(金) 19:30 発言[未読]
【43891】Re:文字列の置換2 訂正 ichinose 06/10/28(土) 12:01 発言[未読]
【43933】Re:文字列の置換2 訂正 miwa 06/10/30(月) 9:26 質問[未読]
【43935】Re:文字列の置換2 訂正 りん 06/10/30(月) 10:15 発言[未読]

【43875】文字列の置換2
質問  miwa  - 06/10/27(金) 12:30 -

引用なし
パスワード
   こちらで教わり、マクロを実際に動かしてみたのですが、
D:\miwa\【QZ】\DB\営業所\当年\1.国内\商品別\Aという
様な階層になっており、実はDBフォルダの下には
30個位のフォルダがあります。
DBフォルダ以下全てのフォルダの中にある
エクセルファイルの全シートの文字列を一気に置換したいのです。
一つ一つフォルダの中にマクロブックをおいてやってみたのですが、
かなり時間のかかる操作で、これでは終わらない(ToT)/~~~
どの部分を直せば、よいのでしょうか?


Sub 置換()
 Dim ws As Worksheet
 Dim wb As Workbook
 Dim strPath As String
 Dim strFileName As String

 Set ws = ActiveSheet
 'ブックが格納されているフォルダ(マクロブックと同じフォルダの場合)
 strPath = ThisWorkbook.Path
 strFileName = Dir(ThisWorkbook.Path & "\*.xls")
 Do Until strFileName = ""
  If strFileName <> ThisWorkbook.Name Then
   'ブックを開く
   Set wb = Workbooks.Open(strPath & "\" & 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 = Dir()
 Loop
End Sub

【43880】Re:文字列の置換2
発言  neptune  - 06/10/27(金) 15:04 -

引用なし
パスワード
   こんにちは
>どの部分を直せば、よいのでしょうか?
どの部分と言われれば、1つのフォルダ内の全てのファイルに対して作業している
のを、フォルダ内の下位フォルダにまで広げればいいです。

過去ログ
http://www.vbalab.net/vbaqa/c-board.cgi?cmd=ntr;tree=36307;id=excel#36307
フォルダのファイルを取得するヒントがありそうです。

これで、全く判らないのなら・・コツコツやってください。

【43881】Re:文字列の置換2
発言  ichinose  - 06/10/27(金) 19:30 -

引用なし
パスワード
   こんばんは。
>こちらで教わり、マクロを実際に動かしてみたのですが、
>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


として、置換を実行してみてください。

【43891】Re:文字列の置換2 訂正
発言  ichinose  - 06/10/28(土) 12:01 -

引用なし
パスワード
   >標準モジュールに
>'========================================================
>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 = false
>     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

【43933】Re:文字列の置換2 訂正
質問  miwa  - 06/10/30(月) 9:26 -

引用なし
パスワード
   このまま使用させていただきました。
SubまたはFunctionが定義されていません。
というエラーが出てしまいました。
IF以降の文がおかしいのでしょうか?

Sub 置換()
 Dim ws As Worksheet
 Dim wb As Workbook
 Dim strFileName As String
 Dim nm As Variant
 'ブックが格納されているフォルダ(マクロブックと同じフォルダの場合)
 If fold_open("D:\miwa\当年", "*.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

【43935】Re:文字列の置換2 訂正
発言  りん E-MAIL  - 06/10/30(月) 10:15 -

引用なし
パスワード
   miwa さん、おはようございます。

>このまま使用させていただきました。
>SubまたはFunctionが定義されていません。
>というエラーが出てしまいました。

この3つも、ちゃんと記述してありますか?
 Function fold_open
 Sub fold_search
 Function fold_get

6660 / 13644 ツリー ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free