| |
マクロを用いてxlsのセルの値をppt上のテキストボックスに転記したいのですが、以下のコードを実行すると複数のセルが1つのテキストボックスに転記されてしまいます。セルごとにテキストボックスも分けたいのですがどのようにすればよいのでしょうか。できればテキストボックスごとにフォントサイズや座標も変更したいと考えています。ご教授願います。
Sub ExceltoPowerPoint()
Dim objRng As Range
Dim varRng As Variant
Dim intSNum As Integer
Dim i As Integer, j As Integer
Dim PpApp As PowerPoint.Application
Dim PpPrs As PowerPoint.Presentation
'Sheet1のセル範囲(B1:F5)の値を変数に格納
Set objRng = Worksheets("Sheet1").Range("A2:E4")
varRng = objRng.Value
Set objRng = Nothing
Set PpApp = CreateObject("PowerPoint.Application")
Set PpPrs = PpApp.Presentations.Add
'PowerPointの表示
PpApp.Visible = True
Set PpPrs = PpApp.Presentations.Open("C:\Users\shori.fuji\Documents\マクロ実験用.ppt")
'スライド番号用変数の初期設定
intSNum = 1
'スライドの作成とテキストボックスの挿入
For i = 1 To UBound(varRng, 1)
PpPrs.Slides.Add i, ppLayoutBlank
'テキストボックスを座標(0,0)の位置にサイズ710×540で作成
PpPrs.Slides(i).Shapes.AddTextbox msoTextOrientationHorizontal, 0, 0, 100, 50
Next
'セルの値をスライド上のテキストボックスに挿入
For i = 1 To UBound(varRng, 1)
For j = 1 To UBound(varRng, 2)
With PpPrs.Slides(intSNum).Shapes(1).TextFrame.TextRange
If j = UBound(varRng, 2) Then
.Text = .Text & CStr(varRng(i, j)) & vbNewLine
intSNum = intSNum + 1
Else
.Text = .Text & CStr(varRng(i, j)) & vbNewLine
End If
End With
Next
Next
'各スライドのテキストボックスのフォント設定
For i = 1 To UBound(varRng, 1)
With PpPrs.Slides(1).Shapes(1).TextFrame.TextRange
.Font.NameAscii = "OCRB" '英数字用フォントの設定
.Font.NameFarEast = "HG丸ｺﾞｼｯｸM-PRO" '日本語用フォントの設定
.Font.NameOther = "OCRB" 'その他フォントの設定
.Lines(1).Font.Size = 14 '1行目のフォントサイズ設定)
.Lines(2).Font.Size = 14 '2行目のフォントサイズ設定)
.Lines(3).Font.Size = 14 '3行目のフォントサイズ設定)
.Lines(4).Font.Size = 14 '4行目のフォントサイズ設定)
.Lines(5).Font.Size = 14 '5行目のフォントサイズ設定)
End With
Next
MsgBox "帳票の作成が完了しました。"
Set PpPrs = Nothing
Set PpApp = Nothing
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
