• 締切済み

Wordテンプレート一括変更でのサブフォルダ検索

ワードに使用されているテンプレートを一括でnormalに戻したいと考えています。 テンプレートを使用したファイルは、かなりの量があるため、Microsoftが公開している方法を用いて一括変更を試みましが、この方法では、1個づつフォルダを指定する必要があります。 そこで、指定したフォルダから下のサブフォルダも含めて変更できるようにするには、どのようにコードを書き換えればよろしいでしょうか？ コードは、ワードのVBEに貼り付けて実行しています。 よろしくお願いいたします。 Dim strFilePath As String Dim strPath As String Dim intCounter As Integer Dim strFileName As String Dim OldServer As String Dim objDoc As Document Dim objTemplate As Template Dim dlgTemplate As Dialog Dim nServer As Integer OldServer = "enter the name of the Old Server" nServer = Len(OldServer) strFilePath = InputBox("What is the folder location that you want to use?") If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & "\" strFileName = Dir(strFilePath & "*.doc") Do While strFileName <> "" Set objDoc = Documents.Open(strFilePath & strFileName) Set objTemplate = objDoc.AttachedTemplate Set dlgTemplate = Dialogs(wdDialogToolsTemplates) strPath = dlgTemplate.Template If LCase(Left(strPath, nServer)) = LCase(OldServer) Then objDoc.AttachedTemplate = NormalTemplate End If strFileName = Dir() objDoc.Save objDoc.Close Loop Set objDoc = Nothing Set objTemplate = Nothing Set dlgTemplate = Nothing

みんなの回答

回答No.1

重要な部分 FileSystemObject（通称 FSO）で再帰処理を行えば指定したフォルダ以下の末端まで掘りながら、全てのファイルを取得することができます。 検索キーワードは「fso」と「再帰」です。 http://www.google.com/search?hl=ja&lr=lang_ja&ie=UTF-8&oe=UTF-8&q=fso+%E5%86%8D%E5%B8%B0&num=50 ただしこのままでは doc ファイルのみならず全てのファイルを取得しますので、取得後にファイルの拡張子を調べ、「拡張子が doc なら処理をする」というように判断を入れてください。

全文を見る
すると、全ての回答が全文表示されます。
  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • 複数のエクセルシートをまとめるマクロ

    下は複数のエクセルファイルを一つにするマクロですが、100万件を超えるためcsvで保存するようにするにはどこを変更したらよいでしょうか。 よろしくお願いします。 Sub Sample() Dim t As Single Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long 'A列に値が入っているデータ数 t = Timer 'まとめたいシート Set WS2 = ThisWorkbook.Worksheets(1) strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Worksheets(1) With WS1.Range("A1") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 14).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With WB1.Close False End If strFileName = Dir Loop MsgBox "まとめ処理をしました。処理時間 " & Format((Timer - t) / 60 / 60 / 24, "h:mm:ss") End Sub

  • 最終セルまでデータを反映させるマクロ

    あるサイトからの利用コードです。 それをアレンジしようとしましたが、つまずきました。 マクロコードをご教示ください。 あるフォルダに複数のエクセルファイルがあります。 構成が同じシート(名前は同じ。仮に "各シート")を、 別ブック(仮に "まとめ")の一つのシートに纏めます。 その時、複数ファイルの D4のデータだけは　"まとめ"ブックのL列に反映させたいのですが、 下記コードを使用すると、どこにどのようなコードを入れたら良いのでしょうか？ 因みに複数ファイルの8行目からコピーされ、 複数ファイルのＣからM列は まとめブックのAからK列に反映されるようになってます。 (まとめブックの1行目は見出し) Dim i As Integer Dim strPath As String Dim strFileName As String Dim WB1 As Workbook Dim WS1 As Worksheet Dim WS2 As Worksheet Dim lngRowCount As Long Set WS2 = Sheets("まとめ") strPath = ThisWorkbook.Path strFileName = Dir(strPath & "\*.xls*") Do While strFileName <> "" If strFileName <> ThisWorkbook.Name Then Set WB1 = Workbooks.Open(strPath & "\" & strFileName) Set WS1 = WB1.Sheets("各シート") With WS1.Range("C7") lngRowCount = .Worksheet.Cells(.Worksheet.Rows.Count, .Column).End(xlUp).Row - .Row If lngRowCount >= 1 Then With .Resize(lngRowCount, 11).Offset(1) .Copy WS2.Range("A" & WS2.Rows.Count).End(xlUp).Offset(1) End With End If End With _____ここで　つまずく_____ 　　 With WS1.Range("D4") 　　　 .Copy WS2.Range("L" & WS2.Rows.Count).End(xlUp).Offset(1) 　　　 WS2.Range("L" & WS2.Rows.Count).End(xlUp).AutoFill Destination = Range("E1048576").End(xlUp).Row _____ここまで　つまずく_____ WB1.Close False End If strFileName = Dir Loop End Sub エクセル2013です。 宜しくお願い致します。

  • サブフォルダ内のファイル名取得について

    Windows7 Access 2013環境です。 USB接続したハードディスク内のファイルリストを作成しようとしています。 ハードディスクはNTFSフォーマットです。 ボタン1をクリックしたとき、テーブル1をソースにしたフォーム1に ファイル名を書き出していくようにしました。 ドライブ内のサブフォルダを選択すると、プログラムは正常に作動するのですが ドライブ直下を指定すると、実行時エラー 70 "書き込みできません" が発生します。 NTFSのアクセス権は、管理者でログインしているので、システム関連のフォルダ System Volume Information $RECYCLE.BIN 以外は問題ありません。 どこに問題があるのでしょうか。もし、システム関連のフォルダが 引っかかっているとしたら、その回避方法についても 具体的にご教授願います。 ↓エラー箇所↓ -------------------------------------------------------------- For Each subfolder In folder.SubFolders -------------------------------------------------------------- ↓作成したプログラム↓ -------------------------------------------------------------- Private Sub ボタン_1_Click() Dim dlg As FileDialog Dim fold_path As String Dim strTargetDir As String DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec Set dlg = Application.FileDialog(msoFileDialogFolderPicker) If dlg.Show = False Then Exit Sub fold_path = dlg.SelectedItems(1) strTargetDir = fold_path Call FolderSearch(strTargetDir) MsgBox "終了" Set dlg = Nothing Else End If End Sub Public Sub FolderSearch(strTargetDir As String) Dim fso As Object Dim folder As Object Dim subfolder As Object Dim file As Object Dim objFilsSys As Object Dim objDrive As Object Dim strDriveLetter As String Set fso = CreateObject("Scripting.FileSystemObject") Set folder = fso.GetFolder(strTargetDir) strDriveLetter = Left(strTargetDir, 1) Set objFileSys = CreateObject("Scripting.FileSystemObject") Set objDrive = objFileSys.GetDrive(strDriveLetter) For Each subfolder In folder.SubFolders　　←エラー箇所 FolderSearch subfolder.Path Next subfolder For Each file In folder.Files With file Me.ボリューム名 = objDrive.VolumeName Me.ファイル名 = file.Name Me.ファイルパス = folder.Path Me.ファイルサイズ = folder.Size DoCmd.GoToRecord acDataForm, "F0001_フォーム1", acNewRec End With Next file Set objDrive = Nothing Set fso = Nothing Set folder = Nothing End Sub

  • 他のブックを開かずに値を取得したい

    お世話になっております。。。 excel2007です。 アクティブである、ThisWorkbookに 外部ファイルから値のみ取得し、ThisWorkbookのA14セルからA27まで 入力させたい・・・ のですが、上手くいきません。 WEB検索して、ExecuteExcel4Macroでやってみたのですが、 Cells(1, C + 13) = ExecuteExcel4Macro("'strFullPath1'!受注書" & "Cells(2, C + 23)") のところで、「値の更新：strFullPath1」と出てしまいます。 どうしたら良いでしょうか？ Private Sub CommandButton1_Click() Const FILE_DIR1 As String = "\\192.168.～" '途中までのパス Const FILE_DIR2 As String = "\\192.168.～～" '途中までのパス Dim strFullPath1 As String Dim strFullPath2 As String Dim strFileName As String Dim フォルダ名 As String Dim C As Integer フォルダ名 = TextBox2.Value & "\" & Range("B4") & "\" strFileName = "*" & Range("B5") & "　" & Range("B6") & ".xls" strFullPath1 = FILE_DIR1 & フォルダ名 & strFileName strFullPath2 = FILE_DIR2 & フォルダ名 & strFileName C = 1 If Dir(strFullPath1) <> "" Then For C = 1 To 14 Cells(1, C + 13) = ExecuteExcel4Macro("'strFullPath1'!受注書" & "Cells(2, C + 23)") Next D Else For C = 1 To 14 Cells(1, C + 13).Formula = "[strFullPath2]sheet!cells(1,D+17)" Cells(1, C + 13).Value = Cells(D, 14).Value Next D End If Unload Me End Sub 端折っているので、抜けがあるかもしれません。 お知恵を頂けますでしょうか？ 宜しくお願い致します。

  • 複数フォルダにある複数ファイルの一括印刷

    下記の通りフォルダの中にある、複数のエクセルファイルを印刷するマクロを使用しています （どこからか、参考にして自分なりに変更したら、出来たのですが・・・） 一つのフォルダに存在する複数フォルダの複数ファイルを、上記同様に印刷する方法は どのようにすればよいのでしょうか？（フォルダは30個位、ファイル１～20個位、増減あり） どなたか、お知恵をお貸しください。お願いいたします。 Sub test() ' '　印刷マクロ ' Dim fol As String Dim f As String Dim wb As Workbook Dim wscnt As Long Dim i As Long fol = "d:\sampul" f = Dir(fol & "\*.xls") Do While f <> "" Set wb = Workbooks.Open(fol & "\" & f) wscnt = wb.Worksheets.Count For i = 1 To 1 wb.Worksheets(i).PrintOut Next i wb.Close f = Dir() Loop Set wb = Nothing End Sub

  • 名前を付けて保存時のファイル名の指定

    ボタンを押すとテーブルのデータが出力できるようにしたいと思います。 標準Module1とFormのボタンには下記のような記述をしていますが 添付ファイルのように保存のダイアログまではうまく動いているようです。 ただ、ファイル名がブランクですので、"表示材料_" & Format(Now(), "yyyymmdd")と自動的に表示させたいです。 ご教授お願いいたします。 【PC環境】 Access:2010 WIndows 7 【標準Module1】 Function GetFileName(OpenOrSaveFlg As Boolean, strFilter As String, _ strTitle As String) As String Dim returnValue As Integer Dim strFilePath As String If strFilter = "" Then strFilter = "全てのファイル (*.*)|*.*" End If WizHook.Key = 51488399 'WIZHOOK有効 returnValue = WizHook.GetFileName( _ 0, "", strTitle, "", strFilePath, "", _ strFilter, _ 0, 0, 0, OpenOrSaveFlg _ ) WizHook.Key = 0 ' WizHook 無効 GetFileName = strFilePath End Function 【Fromのボタン】 Private Sub コマンド28_Click() Dim strFileName As String Dim ExpFileName As String ExpFileName = "表示材料_" & Format(Now(), "yyyymmdd") strFileName = GetFileName(False, "MicrosoftExcel ブック (*.xls)|*.xls", "") If Len(strFileName) = 0 Then 'キャンセルボタンが押されたときの処理を記述 MsgBox "キャンセルが押されました。" Else DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel9, "T_WO_MAT", "", True, "" End If End Sub

  • サブフォルダの親フォルダを変えたい

    フォルダの中のサブフォルダを取得してくて、 http://officetanaka.net/excel/vba/tips/tips95.htm の --------------------------------------------------------- Sub Sample4() Dim buf As String, msg As String buf = Dir("*.*", vbDirectory) Do While buf <> "" If InStr(buf, ".") = 0 Then msg = msg & buf & vbCrLf buf = Dir() Loop MsgBox msg End Sub --------------------------------------------------------- をやってみたら、サブフォルダを取得できたのですが、 上記のコードを実行すると 元々のフォルダのパスが「C:\Users」で、 「C:\Users」のサブフォルダが取得されてしまいます。 でも上記のコードでは、「C:\Users」は指定してないと思うのですが、 なぜ「C:\Users」のサブフォルダが取得されてしまうのでしょうか？ 例えば 「C:\Users」ではなく、「C:\Program Files」のサブフォルダを取得するには、 どのようにコードを書き換えればいいのでしょうか？ ご教授よろしくお願いします。

  • サブフォルダ内の全てのテキストファイルを１発処理する方法

    Excel2007のVBAを使い、下記のようなマクロを作成しました。 （質問に必要そうな所だけ掲載しています。） Dim dir_name As String ' ディレクトリ名 Dim file_name As String ' ファイル名 Dim EffectiveRow As Integer ' 開始行数/Excel/Row(行) Dim ShellApp As Object ' SHDOCVW.DLL / MIC Dim oFolder As Object ' フォルダパス EffectiveRow = Range("A65536").End(xlUp).Row Set ShellApp = CreateObject("Shell.Application") Set oFolder = ShellApp.BrowseForFolder(0, "フォルダ選択", 1) dir_name = oFolder.items.Item.Path ChDir dir_name file_name = Dir("*.txt", vbNormal) Do Until file_name = "" EffectiveRow = EffectiveRow + 1 Call ImportText(file_name, EffectiveRow) file_name = Dir() Loop ShellApp.BrowseForFolderを使い、指定したフォルダを選択すると、 その中に有る、テキストファイル(.txt)を、全てExcelに書き込む というマクロを作成したのですが、もっと汎用性を高くするために、 下記の内容を実現したく思っています。 - ↓ 実現したい事↓ - - 状況 - *フォルダの中に、サブフォルダが複数有り、そのサブフォルダの中に、 テキストファイル(.txt)が複数入っている。 - 処理 - サブフォルダを格納している*フォルダを、ShellApp.BrowseForFolderで 選択し、一度でサブフォルダ内のテキストファイルを全てExcelに書き込 めるようにしたい。 上記のマクロから発展させて、このような処理を行う事は出来るでしょうか？ また、どのようにすれば実現させることが出来るでしょうか？ ご教授のほど、よろしくお願いします。m(_ _)m ※ [*フォルダ ] は同一フォルダです。

  • VBAマクロ　Path名取得について

    msoFileDialogFilePickerで選択したファイルのフォルダ名を取得したいのですが、エラーが出てしまいます。 初歩的な話かと思いますが、解決できず困っています。 よろしくお願い致します。 --------------------------------------- Dim Pfile as String Dim fName as String, fPath as String Set objDialog = Application.FileDialog(msoFileDialogFilePicker) If objDialog.Show Then Pfile = objDialog.SelectedItems(1) End If 　　 Set objDialog = Nothing fName = Dir(Pfile) fPath = Workbooks(fName).Path ↑ここで、「インデックスが有効範囲にありません」

  • CSV形式で出力後、開くときの警告メッセージについ

    いつもお世話になっております。 ACCESSからデータをCSV形式で出力後、ファイルを開くときに添付のような警告メッセージが表示されます。[はい]をクリックすればファイルは開くことができるのですが、警告メッセージが表示されないようにするにはどうしたらいいでしょうか？ xlsxのテンプレートを開き、そこにデータを書き出して、csvで保存するようになっています。csv形式で出力したことがないので、csvのFormatを指定する必要があると思っていますが、どうしたらいいでしょうか？ ご教授お願いいたします。 Private Sub CMD_Expo_DblClick(Cancel As Integer) On Error GoTo Err_FileDialog_Click Dim strsql As String Dim strTemplate As String Dim strFileName As String Dim ExpFileName As String Dim xlapp As Object Dim xlWB As Object Dim myCn As New ADODB.Connection Dim myRs As New ADODB.Recordset 'ファイル名作成 ExpFileName = "SNDFILE" & Format(Date, "yyyymmdd") strFileName = GetFileName(False, "", "", ExpFileName & ".csv") 'EXCELアプリケーションを起動 Set xlapp = CreateObject("Excel.Application") 'セットする過程が見えないよう一旦不可視 xlapp.Visible = False Set myCn = CurrentProject.Connection strsql = "Q_BOFAXExpo_MJ" 'レコードセットオープン myRs.Open strsql, myCn, adOpenForwardOnly, adLockReadOnly With xlapp 'テンプレートを開く strTemplate = Application.CurrentProject.Path & "\" & "SNDFILE.xlsx" Set xlWB = .Workbooks.Open(strTemplate) 'テンプレートファイルが存在しないときはエラー If Dir(strTemplate) = "" Then MsgBox "テンプレートファイルを確認してください。", vbOKOnly + vbCritical, "エラー" .Visible = True .Quit Exit Sub End If 'テンプレートファイルオープン .Workbooks.Open strTemplate '結果値出力処理(1行目にヘッダーを表示しているので、2行目1列目からセット xlWB.Worksheets("Sheet1").Cells(1, 1).CopyFromRecordset myRs '完了したら保存 If Len(strFileName) = 0 Then xlWB.Close SaveChanges:=False xlapp.Quit MsgBox "処理を中止します。", vbOKOnly + vbInformation Exit Sub Else xlWB.SaveAs FileName:=strFileName End If MsgBox "BOFAX用のファイルの出力が完了しました。", vbOKOnly + vbInformation End With Set myRs = Nothing: Close Set myCn = Nothing: Close 'Excelを終了します xlapp.Quit Exit Sub Exit_FileDialog_Click: Exit Sub Err_FileDialog_Click: MsgBox "予期せぬエラーが発生しました" & Chr(13) & _ "エラーナンバー：" & Err.Number & Chr(13) & _ "エラー内容：" & Err.Description, vbOKOnly End Resume Exit_FileDialog_Click End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

あなたにピッタリな商品が見つかる！ OKWAVEセレクト

質問する