PowerPointVBA複数ファイルへの一括日付入力マクロ

前へ 次へ
このQ&Aのポイント
  • PowerPointVBAを使用して、現在開いているpptファイルと同じフォルダ内の全てのpptファイルに対して、1ページ目のサブタイトルに日付を一括で入力するマクロを作成したい。しかし、マクロの実行に時間がかかってしまうため、解決策を探している初心者です。
  • 初心者のため、ヘルプやWeb検索でも解決策が見つからず困っています。現在のマクロでは、Forループの繰り返し毎に全てのファイルを開いてしまっているため、実行時間が長くなってしまっています。
  • マクロの実行時間を短縮する方法や、効率的な処理方法を教えていただきたいです。初心者にも理解しやすい解説やサンプルコードがあれば助かります。よろしくお願いいたします。
回答を見る
  • ベストアンサー

PowerPointVBA複数ファイル一括について

現在開いているpptと同フォルダ内の全てのpptファイルに対して、 1ページ目のサブタイトルに日付を一括で入れるマクロを作成したいのです。 下記のように作成してみたのですが、いちおう全ファイルに希望通りの個所に希望の文字列が入るのですが、実行にものすごく時間がかかりました。。 ステップインで確認すると、"Presentations.Open FileName:="の行で、Forループの繰り返し毎に、全ファイル開いてしまっているようで。。 一般の初心者で、見よう見まねでやっていまして、ヘルプやWeb検索でも、どうしても解決策を見いだせませんでした。 どなたか、ご教示いただけませんでしょうか。 よろしくお願いいたします。_(_ _)_ ------------------------------------------------------------ Sub AddDatetoAllPPT() Dim todaydate As String todaydate = Year(Now) & "年" & Month(Now) & "月" & Day(Now) & "日" Dim myShape As Shape Dim FSO As Object, Files As Variant Set FSO = CreateObject("Scripting.FileSystemObject") Set Files = FSO.GetFolder(ActivePresentation.Path).Files For Each File In FSO.GetFolder(ActivePresentation.Path).Files Presentations.Open FileName:=ActivePresentation.Path & "\" & File.Name Set myShape = ActivePresentation.Slides(1).Shapes("サブタイトル 2") myShape.TextFrame.TextRange.Text = todaydate ActivePresentation.Saved = True Next End Sub

質問者が選んだベストアンサー

  • ベストアンサー
回答No.1

全ファイルが開いてしまっているのは、OpenしてCloseしていないのが原因かと。 取りあえず、サブタイトルを書き込んだあと、 ActivePresentation.Save　　　' これでファイルを保存 ActivePresentation.Close　　 ' これでファイルをクローズ とすればOKのはず。これで、マクロが終了するまでファイルが開きぱなしという ことはなくなります。 あと、ActivePresentation.Saved = True をつけてマクロを実行済みでしょうか？ だとすると、せっかくの変更が保存されずにマクロが終了している可能性が高いです。 普通、変更したけど保存せずに「閉じる」を実施した時に、「変更されてるけど 保存されてないよ。どうすんの？」という意味のダイアログが表示されますよね？ 上記は、本当は保存してないけど保存したと嘘をついて、上記ダイアログの表示を 抑制する効果があります。つまり、変更したけど、保存せずにかつダイアログも出力 させずにファイルを閉じたい場合に使用します。 以上

hiyomail
質問者

お礼

ありがとうございます！ ActivePresentation.Saved = Trueの件、確かめてみると、おっしゃるとおり、 入った変更が保存されずに終わっていたようです。 こちらの行は削除して、お教え頂いた下記をいれたところ、 きちんと変更が保存された状態で閉じられていました。 ありがとうございます_(_ _)_ ActivePresentation.Save　　　' これでファイルを保存 ActivePresentation.Close　　 ' これでファイルをクローズ ただ、やはり実行時間は変わらず、長々と砂時計が表示され・・(;_;) デバックのステップイン実行で動作を観察すると、 常にForループの繰り返し毎に、 Presentations.Open FileName:=ActivePresentation.Path & "\" & File.Name の行で毎回、ばばばっと、1瞬だけ全ファイル開いて閉じた、みたいな表示がされます。 その後の行では、1ファイルずつ開かれて変更して閉じて・・と希望通りの動作をしてくれてるのですが、、 そういう仕様なのですかね。。素人の疑問ですみません。。

hiyomail
質問者

補足

すみません！下の「お礼」を書いてから、気づいたのですが・・・orz 「ばばばっと、1瞬だけ全ファイル開いて閉じた、みたいな表示」という のは・・、そのpptmに含まれているマクロの標準モジュールでした・・。 テストに使っていた同ファイル内のファイルたちが、 実はpptではなく、pptmで、それぞれかなりたくさんの マクロ標準モジュールを持っていたため、開くたびにそれらが、 開きっぱなしのVB Editorにロードされていただけでした。。 マクロを持っていないpptで実行したら、 砂時計など出てこずに実行できました！ 大変失礼いたしました。ありがとうございました_(_ _)_

  1. カテゴリ
  2. [技術者向] コンピューター
  3. プログラミング・開発
  4. Visual Basic

関連するQ&A

  • VBA：2つのCSVファイルを開きたいです。

    エクセル2010のVBAにてCSVファイルを開き結合させるプログラムを組もうとしているのですが、2つ目のCSVファイルを開こうとすると、何故かエラーが出てしまいます。 -------------------------------------------------------------------------------- 1つ目 Sub mobile_FileSearch(Path As String) 'test.csvのデータを検索して開く Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call mobile_FileSearch(Folder.Path) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name = "test.csv" Then Workbooks.Open ("test.csv") End If Next File End Sub ---------------------------------------------------------------------------- 2つ目 Sub local_FileSearch(Path As String) 'bbb.csvのデータを検索して開く Dim FSO As Object, Folder As Variant, File As Variant Set FSO = CreateObject("Scripting.FileSystemObject") For Each Folder In FSO.GetFolder(Path).SubFolders Call local_FileSearch(Folder.Path) Next Folder For Each File In FSO.GetFolder(Path).Files If File.Name = "bbb.csv" Then Workbooks.Open ("bbb.csv")'←ここでエラー End If Next File End Sub ------------------------------------------------------------------------ まったく同じプログラムで、csvファイル名だけ変えただけで実行時エラー1004が出てしまいます。 一体全体何が問題なのでしょうか？

  • VB６・一括でファイル名の変更したいのですが

    VB6でファイルリネームツールを作成しています。 DriveListBox・DirListBox・FileListBox・TextBox*2・コマンドボタン*3を配置しています。 実行して、ドライブ・ディレクトリを選択して、FileListBoxに表示されいるファイルをコマンド2ボタンで全部Text2に表示させています。 そこで、text2からファイル名を直接編集して、コマンド3ボタンで編集したファイル名で保存したいのですが、どう記述すれば良いのでしょうか。 Text1とコマンド1の状態は、FileListboxでクリックしたファイルをText1に表示・編集して、コマンド1でファイル名変更できる状態です。 コマンド3のコードですと、 >Set fsofile = fso.GetFile(Dir1.Path & "\" & File1.FileName) の行が、実行エラー53、ファイルが見つかりません。となります。 宜しくお願いします。 現在のコードです。 Private Sub Command1_Click() 　　Dim fso As New FileSystemObject 　　Set fsofile = fso.GetFile(Dir1.Path & "\" & File1.FileName) 　　fsofile.Name = Text1.Text 　　File1.Refresh end sub Private Sub Command2_Click() 　　Text2.Text = Clear 　　Dim fso As New FileSystemObject 　　For Each myFile In fso.GetFolder(Dir1.Path & "\" & File1.FileName).Files 　　　　Text2.Text = Text2.Text & myFile.Name & vbCrLf 　　Next End Sub Private Sub Command3_Click() 　　Dim fso As New FileSystemObject 　　Set fsofile = fso.GetFile(Dir1.Path & "\" & File1.FileName) 　　fsofile.Name = Text2.Text 　　File1.Refresh End Sub Private Sub Dir1_Change() 　　File1.Path = Dir1.Path End Sub Private Sub Drive1_Change() 　　Dir1.Path = Drive1.Drive End Sub Private Sub File1_Click() 　　Text1.SetFocus 　　Text1.Text = File1.FileName End Sub Private Sub Form_Load() 　　Text1.Text = "" 　　Text2.Text = "" 　　Dir1.Path = App.Path 　　Drive1.Drive = App.Path End Sub

  • VBAでアクティブなファイルを参照して、ファイル一覧作成（サブフォルダ含む）

    VBAでアクティブなファイルのフォルダ（サブフォルダを含む）のファイル一覧を 作成したいと思っています。 以下のサイトを参考にして、パス、ファイル名を落とすまではできました。 http://okwave.jp/qa3544575.html === Sub test() Application.ScreenUpdating = False Sheet1.Cells.Clear Sheet1.Cells(1, 1) = "パス" Sheet1.Cells(1, 2) = "ファイル名" files "d:\", 2 Application.ScreenUpdating = True End Sub Sub files(path As String, ByRef row As Long) DoEvents Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim f As Object For Each f In fso.GetFolder(path).files Sheet1.Cells(row, 1) = path Sheet1.Cells(row, 2) = f.Name row = row + 1 Next For Each f In fso.GetFolder(path).SubFolders files f.path, row Next Set fso = Nothing End Sub === >files "d:\" の箇所を修正して、アクティブなブックを参照しようとしてみたのですが、 なかなか上手くいきません。 また、できれば　*.xls　などファイルの種類を指定したいのです。 filesearchを使用して組んだ時は 「AAA = ActiveWorkbook.path」「Filetype　～　」 などでそれらの指定ができたのですが、上記に応用する事ができません。 どなたかご教示頂けますよう、よろしくお願いいたしますm(_ _)m

  • ファイルサイズを書き込めません。

    過去ログを検索したのですが載っていなかったので質問させて頂きます。 指定したフォルダ毎の容量を管理したいと考え,ネットで拾った以下のソースをEXCELで動かしましたが「書き込みできません」というエラーと共に書き込めませんでした。 Sub FolderSize_Count() Dim FSO As Variant Set FSO = CreateObject("Scripting.FileSystemObject") Dim Path As String With Sheets("Sheet2") Path = Application.Worksheets("sheet1").Range("A1").Value Sheet2.Cells(1, 1) = FSO.GetFolder(Path).Size End With End Sub 書き込めませんというキーワードで検索をGOOGLEでもかけたのですが見つからずに困っています。 もしよろしければご回答お願い致します。

  • 返ってくる値が違う

    VBAでフォルダの中のファイルの個数を取得するコードなのですが Sub test1() Dim i As Long, buf, Path As String Path = ActiveWorkbook.Path & "\" buf = Dir(Path & "*.*") Do While buf <> "" i = i + 1 buf = Dir() Loop MsgBox "「" & ActiveWorkbook.Path & "」には、全部で" & i & "個のファイルがあります。" End Sub Sub test2() Dim Path As String Dim i As Long, FSO As Object, f As Object Path = ActiveWorkbook.Path & "\" Set FSO = CreateObject("Scripting.FileSystemObject") MsgBox "「" & ActiveWorkbook.Path & "」には、全部で" & FSO.GetFolder(Path).Files.Count & "個のファイルがあります。" Set FSO = Nothing End Sub Test1とtest2では返ってくる値が違うのですが なぜでしょうか？ Test2はフォルダの個数も取得されてるのですか？

  • FSOを使いサブフォルダのファイル操作

    同じ階層のサブフォルダにxlsm入るが入っており、VBAによりモジュールを解放しようと試みています。 まずは、FSOを使ってサブフォルダにアクセスしようとしましたが、下から6行目でエラー（424 オブジェクトが必要です）が出てしまい、解決できませんので、ご教示いただけないでしょうか？ よろしくお願いします Sub DeleteMain() With Application.FileDialog(msoFileDialogFolderPicker) If Not .Show Then Exit Sub Call DeleteSub(folderPath:=.SelectedItems(1)) End With End Sub Sub DeleteSub(folderPath As String, Optional mycount As Long = 0) Dim fso As Object, myFolders As Object, myfile As Object Set fso = CreateObject("Scripting.FileSystemObject") Set myFolders = fso.GetFolder(folderPath).SubFolders For Each myfile In fso.GetFolder(folderPath).Files mycount = mycount + 1 ' Cells(mycount, 1) = myfile.Path Debug.Print myfile.Path Next For Each myFolders In fso.GetFolder(folder.Path).SubFolders Call DeleteSub(myFolder.Path, mycount) Next Set fso = Nothing Set myFolders = Nothing End Sub

  • テキストファイルをエクセルに移すマクロのことで？

    以前、複数のテキストファイルをエクセルに移すマクロを教えてもらったのですが、 以下マクロですと、フォルダのパスを指定しないといけません。 今回教えてもらいたいのは、フォルダのパスを指定しなくてもよい方法です。 どういう事かと言うと、仮にディスクトップにフォルダがあるとします。 そのフォルダの中には、マクロが入っているエクセルシートとテキストが入っているフォルダです。 つまり、そのフォルダ内だけで、処理をしたいと考えています。 また、フォルダ名は、その時によって異なります。 今までは、以下の方法を使っていたのですが、ちょっと使いにくいと感じています。 申し訳ありませんが、どなたか教えていただけないでしょうか？ Sub Macro() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim FolderPath As String 'ここのアドレスをファイルが格納されているフォルダのパスに変えてください FolderPath = "C:\Users\・・・" Dim myFile As Object Dim i As Long i = 2 Dim myFolder As Object For Each myFolder In fso.GetFolder(FolderPath).SubFolders For Each myFile In fso.GetFolder(myFolder).Files Cells(i, 4).Value = myFolder Cells(i, 1).Value = myFile.Name Cells(i, 7).Value = fso.OpenTextFile(myFile.Path).ReadAll() i = i + 1 Next Next End Sub Private Sub CommandButton1_Click() End Sub

  • エクセルで複数のフォルダ内のファイルのパスと作成日

    いつもお世話になっております。 だいぶ前にここで表題の質問に対し下記の回答をもらって使っていたのですが、当初はうまく動いているはず（と思った？）ですが、今回明らかにかなりの抜けが有ることが分かりました。A~Zまでのフォルダで抜けているフォルダがいくつもあります。 また、出力の順番が品名フォルダのN、Yから始まって、50音、アルファベット（A、B・・）と順不同。 また、数字で始まる品名のフォルダは無視されているようです。 かなりの確率で抽出されているようなのですが、当方にはどこが悪いのか全く分かりようがないのでHELPさせていただきます。 尚、対象となるファイルが保存されているフォルダー構成は 下記のように・・・・と長いファイルパスの最後に「1.試験成績表」というフォルダに入っている、エクセル、pdf、ワードファイルで、知りたい情報は、当該ファイルのフルパスと作成日です。 Option Explicit Const tgDir = "\\Srv01\部署名\・・・\担当者名\成績書" Const PicDir = "1.試験成績表" Sub Sample() Call setFileList(tgDir) End Sub '//-------------------- Sub setFileList(searchPath) Dim startCell As Range Dim maxRow As Long Dim maxCol As Long Set startCell = Cells(5, 2) 'このセルから出力し始める startCell.Select 'シートをいったんクリア maxRow = startCell.SpecialCells(xlLastCell).Row maxCol = startCell.SpecialCells(xlLastCell).Column Range(startCell, Cells(maxRow, maxCol)).ClearContents Call getFileList(searchPath) startCell.Select End Sub '//-------------------- Sub getFileList(searchPath) Dim FSO As New FileSystemObject Dim objFiles As File Dim objFolders As Folder Dim separateNum As Long 'サブフォルダ取得 For Each objFolders In FSO.GetFolder(searchPath).SubFolders Call getFileList(objFolders.Path) Next 'ファイル名の取得 For Each objFiles In FSO.GetFolder(searchPath).Files separateNum = InStrRev(objFiles.Path, "\") If Right(Left(objFiles.Path, separateNum - 1), Len(PicDir)) = PicDir Then 'セルにパスとファイル名を書き込む ActiveCell.Value = Left(objFiles.Path, separateNum - 1) ActiveCell.Offset(0, 1).Value = Right(objFiles.Path, Len(objFiles.Path) - separateNum) ActiveCell.Offset(0, 2).Value = FileDateTime(objFiles) ActiveCell.Offset(0, 3).Value = Format((FileLen(objFiles) / 1024), "#.0") ActiveCell.Offset(1, 0).Select End If Next End Sub

  • マクロで質問です

    下記のようなマクロで現在はマクロコード内にフォルダのアドレスを書いていますが これをダイアログを開いてフォルダを選択できるようにするには どうすればよいでしょうか？ Sub Sample10()    Call FileSearch("V:\個人\飯塚\マクロ\RawData2") End Sub Sub FileSearch(Path As String) Application.ScreenUpdating = False    Dim FSO As Object, Folder As Variant, File As Variant    Set FSO = CreateObject("Scripting.FileSystemObject")    For Each Folder In FSO.GetFolder(Path).SubFolders        Call FileSearch(Folder.Path)    Next Folder    For Each File In FSO.GetFolder(Path).Files        If File.Name = "RawData" Then Workbooks.Open fld & File, Format:=2 Range("B1:B180").Select Application.CutCopyMode = False Selection.Copy Application.DisplayAlerts = False ActiveWindow.Close Application.DisplayAlerts = True Range("f2").Select ActiveSheet.Paste ActiveSheet.Next.Activate End If    Next File End Sub

  • 複数のtｘtファイルをエクセルに貼りつける方法 ２

    前回質問した者です。 http://okwave.jp/qa/q7062908.html ある特定のフォルダ内に複数のフォルダがあり、その中の各フォルダには、txtファイルが複数あります。 ＶＢＡを使ってエクセルのＡ列にフォルダ名、Ｂ列にtxtファイル名、C列にはtxtファイルの内容を入れたいです。（今はコピペを手動で行っています） フォルダＡ ↓ フォルダ１、フォルダ２、フォルダ３、・・・・ ↓ 各フォルダにはtxtファイル（改行あり） ＶＢＡは解らないのですが、自分なりに検索してみて、以下のコードを見つけました。 しかし、以下の場合はＡ列にtxtファイルの内容しか入らず、また、特定のフォルダのみしか反映されません。 そこで、フォルダＡのパスだけを指定して、Ａ列にフォルダ名、Ｂ列にtxtファイル名、C列にはtxtファイルの内容を入れるにはどうすればいいのでしょうか？ Sub Macro() Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim FolderPath As String 'ここのアドレスをファイルが格納されているフォルダのパスに変えてください FolderPath = "H:\Documents and Settings\asano\デスクトップ\TEST" Dim myFile As Object Dim i As Long i = 1 For Each myFile In fso.GetFolder(FolderPath).Files Cells(i, 1).Value = fso.OpenTextFile(myFile.Path).ReadAll() i = i + 1 Next End Sub

注目のQ&A

カテゴリ

専門家に質問してみよう

職業から探して質問する

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

質問する