ズバリこれ！
[VB]
= Cells(Rows.Count, 1).End(xlUp).Row + 1
[/VB]
VBA
一覧
PowerPoint VBA 【005】目次生成
PowerPointには残念ながらWordのような目次を自動生成する機能がありません。
そこで、以下の方法で目次の作成を行います。
①見出し設定(PowerPoint)
見出しにしたい、テキストボックスのオブジェクト名に
ラベルを設定する。１から５のレベルを設定できます。
・設定用PowerPointアドインマクロも用意してます。（現在準備中）
以下の様に、設定してもＯＫです。
標準機能で設定できます。
②見出し抽出(Excel)
オブジェクト名にラベルが設定された見出し、
スライド番号(ページ)を抽出し、目次の生成を行う。
（現在準備中）
③目次貼付(あなたの手)
②で生成した目次をコピー＆ペーストで貼り付ける。
表形式のまま貼付を行ってください。
※テキスト形式での貼付でも問題ないが、
後述のＰＤＦしおり作成で利用できないので注意！
目次生成は以上です。
Excel VBA 【001】ファイル複製
同じようなファイルをたくさん作成したい場合に利用して下さい。
複製元ファイルは処理中ダイアログで選択します。
このマクロが存在するブックと同じフォルダに格納してください。
エクセルの表で指定したファイル名に複製（コピー）します。
沢山のファイルを作成する場合に便利です。
以下のような表(シート)を準備してください。
マクロ実行用のボタンをつけてますが、
無くてもよいです。
VBA(マクロ)は以下のようになります。
このマクロを実行すれば指定したファイル名のファイルが複製されます。
Sub E_001()
'--------------------------------------------------------------------
'ファイルを複製する。
'--------------------------------------------------------------------
Dim fname1 As String
Dim mypath As String
Dim ws1 As Worksheet
Dim c1 As Long
Dim fd1 As Object
Set ws1 = ActiveSheet
'----- コピー元取得 -----
Set fd1 = Application.FileDialog(msoFileDialogOpen)
With fd1
.Title = "複製元ファイルを指定して下さい。"
.InitialFileName = ThisWorkbook.Path
.Filters.Clear 'フィルタをクリア
.Filters.Add "All File", "*.*", 1
.AllowMultiSelect = False
If .Show <> -1 Then Exit Sub
End With
fname1 = fd1.SelectedItems.Item(1)
mypath = Left(fname1, InStrRev(fname1, "\"))
'----- 複製処理 -----
c1 = 2
While (ws1.Cells(c1, 1) <> "")
FileCopy fname1, mypath & ws1.Cells(c1, 1)
c1 = c1 + 1
Wend
c1 = c1 - 2
If (c1 > 0) Then
MsgBox (StrConv(c1, vbWide) & "ファイル複製しました。")
End If
End Sub
自分でVBAを登録できない方は
以下のExcelをダウンロードして使って下さい。
E_001
PowerPoint VBA 【004】図形変更（グループ化）
グループ化されたオブジェクトの処理を追加しました。
フォント変更と同様に【003】ではグループ化されたオブジェクトが
対象になりません。
Sub PPT004()
Dim sld As Slide
Dim shp As Shape
'***** 選択した全スライド
For Each sld In ActiveWindow.Selection.SlideRange
'***** 全シェイプ
For Each shp In sld.Shapes
'*** グループ化されているオブジェクト
If (shp.Type = msoGroup) Then
Call grp_proc(shp)
Else
'オートシェイプの処理
Call shape_proc(shp)
End If
Next shp
Next sld
End Sub
全スライドを対象にするには
'***** 全スライド
For Each sld In ActivePresentation.Slides
グループ化の処理です。
グループ化されているオブジェクトがなくなるまで
繰り返します。
Sub grp_proc(shp As Shape)
'***** グループ化されている場合の処理 *****
Dim grp As Shape
'*** グループ内のオブジェクト分繰り返す
For Each grp In shp.GroupItems
'さらにグループ化されている
If (grp.Type = msoGroup) Then
Call grp_proc(grp)
Else
'オートシェイプの処理
Call shape_proc(grp)
End If
Next grp
End Sub
オブジェクト変更の処理です。
ここで実際の更新処理を行ってます。
Sub shape_proc(shp As Shape)
'***** シェイプの処理 *****
If (shp.Type = msoAutoShape) Then
'正方形／四角形で枠線が黒色
If (shp.AutoShapeType = msoShapeRectangle) And _
(shp.Line.ForeColor.RGB = RGB(0, 0, 0)) Then
'枠線を赤色に変更
shp.Line.ForeColor.RGB = RGB(255, 0, 0)
End If
End If
End Sub
オブジェクト変更部分、とグループ化の処理は
同じ処理を何度か書く必要があるので、ルーチン化しました。
構造化プログラミングです。
グループ化の処理は再帰化ロジックとなってます。
（自分で自分をコールしてます）
PowerPoint VBA 【003】図形変更
選択したスライドの図形を一括変更するVBAを作成しました。
選択されたスライドでを持っているオブジェクトについて
指定したフォント以外の場合、フォントを変更しています。
Sub PPT003()
Dim sld As Slide
Dim shp As Shape
'***** 選択した全スライド
For Each sld In ActiveWindow.Selection.SlideRange
'***** 全シェイプ
For Each shp In sld.Shapes
'オートシェイプ対象
If (shp.Type = msoAutoShape) Then
'正方形／四角形で枠線が黒色
If (shp.AutoShapeType = msoShapeRectangle) And _
(shp.Line.ForeColor.RGB = RGB(0, 0, 0)) Then
'枠線を赤色に変更
shp.Line.ForeColor.RGB = RGB(255, 0, 0)
End If
End If
Next shp
Next sld
End Sub
全スライドを対象にするには
'***** 全スライド
For Each sld In ActivePresentation.Slides
例では枠線の色を変更してますが、
他の属性に変更したり、いろいろ応用出来ると思います。
PowerPoint VBA 【002】フォント変更(グループ化)
【００１】で出来たと思いましたが、まだ完璧ではありませんでした。
単純なオブジェクトはこれでＯＫですが、
グループ化されているオブジェクトはＮＧでした。
グループ化されたオブジェクトのがある場合のロジックを追加します。
本当にこのような方法しかないのか？ですが。。。
ExcelやWordでもこんな事、したかな？
最近、PowerPoint以外触ってないので、忘れましたが、
こんな事しなくてもオブジェクトで拾えたように思います。
Sub PPT002() Dim sld As Slide Dim shp As Shape Dim wkstr As String '***** 選択スライド For Each sld In ActiveWindow.Selection.SlideRange '***** 全シェイプ For Each shp In sld.Shapes '*** テキストフレームを持っているオブジェクト *** If (shp.HasTextFrame = msoTrue) And _ (shp.TextFrame.HasText = msoTrue) Then Call text_proc(shp) End If '*** グループ化されているオブジェクト If (shp.Type = msoGroup) Then Call grp_proc(shp) End If Next shp Next sld End Sub
Sub text_proc(shp As Shape) If (shp.TextFrame.TextRange.Font.Name <> "Times New Roman") Then shp.TextFrame.TextRange.Font.Name = "Times New Roman" End If If (shp.TextFrame.TextRange.Font.NameFarEast <> "ＭＳ 明朝") Then shp.TextFrame.TextRange.Font.NameFarEast = "ＭＳ 明朝" End If End Sub
Sub grp_proc(shp As Shape) Dim grp As Shape '*** グループ内のオブジェクト分繰り返す For Each grp In shp.GroupItems ' テキストを保有しているオブジェクト If (grp.HasTextFrame = msoTrue) And _ (grp.TextFrame.HasText = msoTrue) Then Call text_proc(grp) End If 'さらにグループ化されている If (grp.Type = msoGroup) Then Call grp_proc(grp) End If Next grp End Sub
フォント変更部分、とグループ化の処理は
同じ処理を何度か書く必要があるので、ルーチン化しました。
構造化プログラミングです。
グループ化の処理は再帰化ロジックとなってます。
（自分で自分をコールしてます）
PowerPoint VBA 【001】フォント変更
選択したスライドのフォントを一括変更するVBAを作成しました。
選択されたスライドのテキストを持っているオブジェクトについて
指定したフォント以外の場合、フォントを変更しています。
Sub PPT001()
Dim sld As Slide
Dim shp As Shape
'***** 選択した全スライド
For Each sld In ActiveWindow.Selection.SlideRange
'***** 全シェイプ
For Each shp In sld.Shapes
'*** テキストフレームを持っている ***
If (shp.HasTextFrame = msoTrue) And _
(shp.TextFrame.HasText = msoTrue) Then
'*** 英字フォントを「Times New Roman」に統一
shp.TextFrame.TextRange.Font.Name = "Times New Roman"
'*** 日本語フォントを「ＭＳ 明朝」に統一
shp.TextFrame.TextRange.Font.NameFarEast = "ＭＳ 明朝"
End If
Next shp
Next sld
End Sub
例ではフォントを変更してますが、
色やサイズ等の属性やテキストを修正したり
いろいろ応用出来ると思います。
全スライドを対象にするには
'***** 全スライド
For Each sld In ActivePresentation.Slides
スポンサーリンク