- 締切済み
パワーポイント2003のマクロについて
OSはXP、パワーポイント2003を使っています。スライドが15枚あります。１５枚には３パターンで使用するスライドが入っています。パターン1では必要なスライドは８枚、パターン2では10枚、パターン3では13枚です。不要なスライドを削除するために、ネットで調べてマクロによる削除まで出来ました。スライドの削除は途中のスライドを削除したりするので、表題に付与している項目番号が変わります。 表題の項目番号はスライドの一番左上に記載しています。 マクロで文中に「1-（1）」「1-（2）」「1-（3）」「1-（4）」「2-（1）」「2-（2）」「3-（1）」を記載して、指定するスライドの左上に書き込むことは出来るでしょうか。もしくはマクロを実行させるＰＰＴのファイルがあるのですが、これの２枚目以降のスライドに項目番号を記載し、コレをコピー＆ペーストで実行することが出来るでしょうか。 教えていただける方、どうぞよろしくお願いします。 スライドを削除するＶＢＡは下記で実行できました。 Sub pt1() ' ' マクロ記録日: 2012/5/28 ユーザー名: Dim myPath As String Dim PPTName As String Dim ThisPresentation As Presentation Dim CurrentPPT As Presentation Set ThisPresentation = ActivePresentation myPath = ActivePresentation.Path '自ファイルのパス取得 If Right$(myPath, 1) <> "\" Then myPath = myPath & "\" End If PPTName = Dir(myPath & "会議資料（原本）.ppt") If PPTName <> ThisPresentation.Name Then Set CurrentPPT = Presentations.Open(myPath & PPTName) 'ファイル開く End If ActiveWindow.View.GotoSlide Index:=15 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=14 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=13 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=12 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=11 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=10 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=9 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=8 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=7 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=4 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=3 ActiveWindow.Selection.SlideRange.Delete ActiveWindow.View.GotoSlide Index:=1 ActiveWindow.Selection.SlideRange.Delete MsgBox "作成終了" End Sub
- katanohosi
- お礼率92% (24/26)
- その他MS Office製品
- 回答数1
- ありがとう数1
- みんなの回答 （1）
- 専門家の回答
みんなの回答
- DreamyCat
- ベストアンサー率56% (295/524)
１５枚づつ３セット分のスライドを複製して 不要なスライドを手で削除して １枚目のスライドからハイパーリンクで目的別スライドショーにリンクするのではだめですか？ 何でもマクロというのではなく どうしても通常の方法ではできないことをマクロでやるのがいいです。 ここに提示したマクロを考え質問している時間があれば、手作業でとっくに終わっているでしょう。
関連するQ&A
- パワーポイントのスライド番号の取得をしたい
はじめまして パワーポイント２００７におきまして、プレゼンテーション実行中に、 マウスにてスライド内のボタンを押すと「現在のページ数＋１０ページ先のページに飛ぶ」というような動作を行わせようとしています。 http://support.microsoft.com/kb/163194/ja の ActiveWindow.Selection.SlideRange.SlideNumber を利用し、 ======================================================= Sub TenPageGo() PN = ActiveWindow.Selection.SlideRange.SlideNumber GO = PN + 10 SlideShowWindows(Index:=1).View.GotoSlide Index:=GO End Sub ======================================================= といったマクロにて実行を考えましたが、 ActiveWindow.Selection.SlideRange.SlideNumber は、プレゼンテーション中には動作してくれない模様です。 よって、プレゼンテーション中に現在表示中のプ レゼンテーション番号を取得する方法をご教授いただきたくお願い申し上げます。
- ベストアンサー
- その他MS Office製品
- Power Point 2007のマクロについて
はじめまして 業務効率化のためマクロを使うようになった初心者ユーザーです。 Power point2007を用いてすべてのページの画像を一括でサイズ変更と位置変更を行いたいと思っています。 見よう見まねで下記のようなマクロを組んでみたのですが、 タイトルテキストもサイズ変更されてしまうので除外したいのですが、どのようにすればよろしいでしょうか？ またこのサイズ変更した画像だけを他のpowerpointファイルに画像1枚1ページずつ自動で貼り付けたいのですが、その方法も教えてほしいです。 なお、他のファイルの既存スライドに貼り付けを行おうとしています。 （画像に関しての説明文書が既に記入済み） お手間を取らせて申し訳ないのですが、迷える子羊に愛の手をお願いいたします。 Public Sub 画像サイズ変更と位置合わせマクロ() Dim i As Long For i = 1 To ActivePresentation.Slides.Count ActiveWindow.View.GotoSlide i ActiveWindow.Selection.SlideRange.Shapes.SelectAll With ActiveWindow.Selection.ShapeRange .Fill.Transparency = 0# .Height = 401# .Width = 687.09 .Left = 20# .Top = 56.62 End With Next End Sub
- ベストアンサー
- その他MS Office製品
- パワーポイント オブジェクトへ複数の動作設定を実行させたい
複数のスライド(フォルダの階層アリ）をリンクして資料を作成しています。 しかし、その資料を閲覧していると、たくさんのパワーポイントファイルが開いたままになり、それの解消策を考えています。 単純にまず２つのファイルの例で考えてみます。 １．Ａスライド → Ｂスライドへ ハイパーリンクで飛びます。 ２．Ｂスライドの最後のページにＡスライドへ戻るリンクボタンが あります。 このＢスライドのボタンにＢスライドの終了と、Ａスライドへのリンクを登録したいのです。 通常パワーポイントの「オブジェクトの動作設定」では、1つのことしか選べません。 ですので、マクロでやってみようと思いました。 しかし記録マクロの知識しかなく、２回に分けて記録したマクロを いろいろ編集してみましたが、今度は何も動かなくなります。 最後の黒い画面までいけば終了するのですが、そうでなくリンクして いければと思っています。 マクロで可能でしょうか？他にアイデアなどありましたら、ご指導 アドバイスをどうぞよろしくお願いします。 office2003 winXP HE 資料は最終的にプレゼンテーションパックにてCDにします。 記録マクロ１ Sub 終了() ActiveWindow.Selection.SlideRange.Shapes("AutoShape 26").Select With ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseClick) ActivePresentation.Close .SoundEffect.Type = ppSoundNone .AnimateAction = msoTrue End With With ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseOver) .Action = ppActionNone .SoundEffect.Type = ppSoundNone .AnimateAction = msoFalse End With End Sub 記録マクロ２ Sub リンク2() ActiveWindow.Selection.SlideRange.Shapes("AutoShape 26").Select With ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseClick) .Hyperlink.Address = "D:\スライドA.pps" .SoundEffect.Type = ppSoundNone .AnimateAction = msoTrue End With With ActiveWindow.Selection.ShapeRange.ActionSettings(ppMouseOver) .Action = ppActionNone .SoundEffect.Type = ppSoundNone .AnimateAction = msoFalse End With End Sub
- 締切済み
- オフィス系ソフト
- PowerPointスライドショーのマクロ
Office XPのPowerPointのマクロで2つのスライドショーを制御したいと考えています。 <想定している動作> 1)スライドショーAはエンドレスで流れている 2)スライドショーA内にあるリンクボタンを押すと、スライドショーBが流れ始める(マクロを実行) 3)スライドショーBは1回流れるとスライドショーAに切り替わる 4)スライドショーAがエンドレスで流れ始める マクロを途中まで作成したのですが、4)で、スライドショーAがリンクボタンを押した状態のまま固まってします。 ソースは以下です。 Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Sub slide() PowerPoint.Presentations.Open ("C:\スライドB.ppt") With ActivePresentation.Slides.Range.SlideShowTransition .AdvanceOnClick = msoFalse .AdvanceOnTime = msoTrue '表示秒数 .AdvanceTime = 30000 End With With ActivePresentation.SlideShowSettings .ShowType = ppShowTypeSpeaker .LoopUntilStopped = msoFalse '繰り返し上映はしない .ShowWithNarration = msoTrue .ShowWithAnimation = msoTrue .RangeType = ppShowAll .AdvanceMode = ppSlideShowUseSlideTimings .PointerColor.SchemeColor = ppForeground .Run End With Sleep (1000) SlideShowWindows(Index:=1).View.Next Sleep (1000) SlideShowWindows(Index:=1).View.Next Sleep (1000) SlideShowWindows(Index:=1).View.Exit Sleep (1000) ActivePresentation.Close PowerPoint.ActiveWindow.Activate End Sub どなたかお分かりになる方いらっしゃいますか？ 上のソースをベースにしなくても良いので、ぜひアドバイスお願いします！
- ベストアンサー
- オフィス系ソフト
- スライド内のオブジェクトを消すマクロ
PowerPointのVBAマクロで、スライド中にspaceという文字列のみのテキストボックス以外のオブジェクトを消すマクロを以下のように作成したのですが、このマクロを実行しても、いくつかのオブジェクトが残ってしまいます。 Sub foo() Dim f As Boolean Dim sl As Slide Dim sh As Shape For Each sl In ActivePresentation.Slides For Each sh In sl.Shapes If sh.HasTextFrame Then If sh.TextFrame.TextRange.Text <> "space" Then sh.Delete End If End If Next Next End Sub コレクションをFor eachで回しているので、漏れはないはずなのですが、どなたか原因・対策をご教示いただけないでしょうか？
- ベストアンサー
- Visual Basic
- 画像に名前を付けたい・変更したい
パワポ２００３です。 新規でプレゼンテーションを立ち上げて 外部から持ってきた画像をスライド上に張り付けて マクロの記録を押して、外部画像を動かすと Sub Macro1() ActiveWindow.Selection.Unselect ActiveWindow.Selection.SlideRange.Shapes("Picture 4").Select With ActiveWindow.Selection.ShapeRange .IncrementLeft 22.5 .IncrementTop -372# End With End Sub と記録されたのですが、「Picture 4」の部分を変更することはできますか？
- ベストアンサー
- オフィス系ソフト
- エクセルのマクロで画像を貼り付け
画像をエクセルに貼り付ける作業を行っています。 マクロを使いファイル内の画像（約３０枚程度）を１列づつスペースを空け 右方向に４枚 １行スペースを空け ３行目の左に戻り その位置よりまた１列づつスペースを空け右方向に４枚・・・・・ これを繰り返しファイル内の画像をすべて 貼り付けたいのですがうまく動作が出来ません。 何卒ご教授の程よろしくお願いします。 ※マクロ Sub EggFunc_pasteDirImage() ' 変数定義 Dim fileName As String Dim targetCol As Integer Dim targetRow As Integer Dim targetCell As Range Dim shell, myPath Dim pos As Integer Dim extention As String Dim isImage As Boolean ' 選択セルを取得 targetCol = ActiveCell.Column targetRow = ActiveCell.Row ' フォルダ選択画面を表示 Set shell = CreateObject("Shell.Application") Set myPath = shell.BrowseForFolder(&O0, "フォルダを選んでください", &H1 + &H10, "C:\Users\0602116.MS\Desktop\") Set shell = Nothing ' フォルダを選択したら... If Not myPath Is Nothing Then fileName = Dir(myPath.Items.Item.Path + "\") Do While fileName <> "" ' ファイル拡張子の判別 isImage = True pos = InStrRev(fileName, ".") If pos > 0 Then Select Case LCase(Mid(fileName, pos + 1)) Case "jpeg" Case "jpg" Case "gif" Case Else isImage = False End Select Else isImage = False End If ' 拡張子が画像であれば If isImage = True Then ' 貼り付け先を選択 Cells(targetRow, targetCol).Select Set targetCell = ActiveCell ' 画像読込み ActiveSheet.Pictures.Insert(myPath.Items.Item.Path + "\" + fileName).Select ' 画像が大きい場合、画像サイズをセル幅に合わせる If Selection.Width > targetCell.Width Or Selection.Height > targetCell.Height Then If Selection.Width / targetCell.Width > Selection.Height / targetCell.Height Then Selection.Height = Selection.Height * (targetCell.Width / Selection.Width) Selection.Width = targetCell.Width Else Selection.Width = Selection.Width * (targetCell.Height / Selection.Height) Selection.Height = targetCell.Height End If End If ' 表示位置をセル中央に移動 Selection.Top = targetCell.Top + (targetCell.Height - Selection.Height) / 2 Selection.Left = targetCell.Left + (targetCell.Width - Selection.Width) / 2 ' 貼り付け先行を+1 targetCol = targetCol + 2 End If fileName = Dir() Loop MsgBox "画像の読込みが終了しました" End If End Sub
- ベストアンサー
- Visual Basic
- Excelのマクロで同じ処理を実行
Excelのマクロについてです。 この度、フォルダ内にあるデータから傾きを抽出して、 データシートにまとめる作業を求められています。 一度ずつ開いて行うのが大変なので、マクロを用いようと思っています。 Sub マクロループ() Dim myPath As String Dim myFile As String myPath = "C:\test\" myFile = Dir(myPath & "*.CSV*") Do Until myFile = "" Workbooks.Open myPath & myFile （ ActiveWindow.ScrollRow = 2 ActiveWindow.ScrollRow = 3 ~ ~ ActiveSheet.Shapes("グラフ 1").IncrementLeft -125.25 ActiveSheet.Shapes("グラフ 1").IncrementTop 21.75 Application.CommandBars("Format Object").Visible = False ） ActiveWorkbook.Close True myFile = Dir() Loop End Sub ~の部分に省略した処理が入ります。 これでエラーなどは起きないのですが、開いて閉じるだけになってしまっています。 （）で括られた部分だけで実行すると、そのファイルで傾きを表示してくれます。 これを全ファイルでやりたいのですが、お力添えをお願いします。 また、それぞれで得られた傾きをデータシートに自動で入力することなどができればそれも教えていただければ幸いです。 どうかよろしくお願いします。
- 締切済み
- Visual Basic
- マクロ もし特定の列が無かったら、何もしないが、有った場合は、マクロを
マクロ もし特定の列が無かったら、何もしないが、有った場合は、マクロを実行したいです。 Excel2003です。 Sub a5_Click() Dim Koumoku(6) As String Dim i As Long Koumoku(0) = "日時" : (省略) Koumoku(6) = "submit2" For i = 0 To 6 Cells.Select Selection.Find(What:=Koumoku(i), MatchCase:=False).Select Selection.EntireColumn.Delete Shift:=xlToLeft Next i と入力し、マクロを実行させています。 マクロを実行し、列を削除させてはいますが、再度マクロを実行すると、実行時エラーが表示されます。すでに、その列が無い為だと思いますが、 「「日時」という列が存在しなかった場合、何もしない だけど、あったら‥‥先ほど書きましたマクロを実行させたいと思っていますが、そのコードをどう書いたら良いでしょうか？
- ベストアンサー
- オフィス系ソフト
- EXCELマクロ、ループかけるとマクロが固まる
「フォルダ内の全てのExcelファイルに対してループを実行する」マクロを組むと、カーソルがぐるぐるして正常に起動していないように思えます。ループ無しであればさくさく動きます。ループ無しの場合は、ファイル１つ１つを自分で開けてマクロを起動。マクロは下記の通り。初心者です。 Sub NEM_Macroループ() ' ' フォント変更、記号変換、テキストボックス、全シート ' Dim myFile As String Dim myPath As String Dim myBook As Workbook Dim mySheet As Worksheet Dim myRange As Range Dim cell Application.ScreenUpdating = False 'フォントを変更するファイルが保存されているフォルダのパスを指定します。 myPath = "C:\Users\N000000\Desktop\NEM_macro" '指定したフォルダ内の全てのExcelファイルに対してループを実行します。 myFile = Dir(myPath & "\*.xlsx") Do While myFile <> "" '各ファイルを開きます。 Set myBook = Workbooks.Open(myPath & "\" & myFile) '全てのワークシートに対してループを実行します。 For Each mySheet In myBook.Sheets 'シート内の全てのセルに対してループを実行します。 Set myRange = mySheet.UsedRange For Each cell In myRange Cells.Select With Selection.Font .Name = "ＭＳ Ｐゴシック" .Name = "Arial" End With Selection.Replace What:="、", Replacement:="，" Selection.Replace What:="※", Replacement:="*" Selection.Replace What:="①", Replacement:="(1)" Selection.Replace What:="②", Replacement:="(2)" Selection.Replace What:="③", Replacement:="(3)" Selection.Replace What:="④", Replacement:="(4)" Selection.Replace What:="⑤", Replacement:="(5)" Selection.Replace What:="⑥", Replacement:="(6)" Selection.Replace What:="⑦", Replacement:="(7)" Selection.Replace What:="⑧", Replacement:="(8)" Selection.Replace What:="⑨", Replacement:="(9)" Selection.Replace What:="⑩", Replacement:="(10)" '半角全角修正 Dim セル As Range Dim 変換文字 As String Dim 半角 As String Dim i As Long ActiveSheet.UsedRange.Select For Each セル In Selection 変換文字 = StrConv(セル.Text, vbWide) For i = 1 To Len(変換文字) 半角 = StrConv(Mid(変換文字, i, 1), vbNarrow) If Asc(半角) >= 32 And Asc(半角) <= 126 Then _ 変換文字 = WorksheetFunction.Replace(変換文字, i, 1, 半角) Next i セル = 変換文字 Next 'テキストボックスグループ化解除 Dim mySPg As Shape For Each mySPg In ActiveSheet.Shapes If mySPg.Type = msoGroup Then mySPg.Ungroup End If Next mySPg Dim mySP As Shape 'すべての図形テキストボックスをループ For Each mySP In ActiveSheet.Shapes 'テキストボックスの場合 If mySP.Type = msoTextBox Then 'フォント変更 mySP.TextFrame2.TextRange.Font.NameFarEast = "ＭＳ Ｐゴシック" mySP.TextFrame2.TextRange.Font.NameFarEast = "Arial" End If Next mySP Next Dim 年月 Dim ThisName, NewName Dim MojiCoA As Integer, MojiCoB As Integer 'Format,Year,Month関数を利用します 年月 = Year(Date) & "_" & Month(Date) '拡張子なしのファイル名を取得します MojiCoA = InStrRev(ActiveWorkbook.Name, ".") ThisName = Left(ActiveWorkbook.Name, MojiCoA - 1) 'ファイル名を変数へ設定します NewName = ActiveWorkbook.Path & "\" & ThisName & 年月 & ".xlsx" '作成したWorkbookを名前を付けて、移動先フォルダに保存します ActiveWorkbook.SaveAs Filename:=NewName '次のファイルに移動します。 myFile = Dir() Next Loop End Sub
- ベストアンサー
- Excel（エクセル）
お礼
思ってもみなく、早期のご教示ありがとうございます。すごくうれしいです。 実は、説明がうまくなかったのですが、毎月月毎のデータをＰＰＴに記載しています。それに加えて３ヶ月ごとの四半期には、毎月に追加したデータを、半年ごとには毎月と四半期のデータを記載した資料を作成しています。もともと３種類の（ご教示のあった３セット）資料を用意してそれぞれにデータを記載していたのですが、様式の変更や、記述の変更があったときは３種類とも修正が必要になることと、四半期、半期に記載する毎月データは四半期の場合、次の四半期の作成時は、３ヶ月前の毎月データが記載されているので、最新の毎月のデータと差異がないか、半期でも同様で、これを問題としています。ですから、様式を一本化しこれらのリスクを回避したいと考えました。 やはり、ＶＢＡでの対応は無理なのでしょうか？