こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

締切り済みの質問

ExcelのデータをPPTにエクスポートしたいです(VBA初心者)

ExcelのデータをPPTにエクスポートしたいです(VBA初心者)
ネット検索などをして、下記の手順でエクスポートすることまではできたのですが、
これだと全てのセルデータがPPTの1つのテキストに入ってしまいます。

希望しているのは、セルごとにエクスポート先の
テキストボックスを分けたいのですが、
ここから先が分かりません。
どなたかご教授いただけませんか。

よろしくお願いします。

<Excel>
A B C D E
1 会社名(1) 住所(1) 担当者(1)
2 会社名(2) 住所(2) 担当者(2)
3 会社名(3) 住所(3) 担当者(3)

<PPT>
・Sheet1
テキストボックス1   会社名(1)
テキストボックス2   住所(1)
テキストボックス3   担当者(1)


・Sheet2
テキストボックス1   会社名(2)
テキストボックス2   住所(2)
テキストボックス3   担当者(2)



---------------------------------------
Sub ExceltoPowerPoint()
Dim objRng As Range
Dim varRng As Variant
Dim intSNum As Integer
Dim i, j As Integer

Dim PpApp As PowerPoint.Application
Dim PpPrs As PowerPoint.Presentation

Set objRng = Worksheets("Sheet1").Range("A1:C5")
varRng = objRng.Value
Set objRng = Nothing

Set PpApp = CreateObject("PowerPoint.Application")
Set PpPrs = PpApp.Presentations.Add


PpApp.Visible = True

intSNum = 1

For i = 1 To UBound(varRng, 1)
PpPrs.Slides.Add i, ppLayoutBlank

PpPrs.Slides(i).Shapes.AddTextbox msoTextOrientationHorizontal, 0, 0, 710, 540
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(i).Shapes(1).TextFrame.TextRange
.Font.NameAscii = "Arial"
.Font.NameFarEast = "MS Pゴシック"
.Font.NameOther = "Arial"
.Lines(1).Font.Size = 10 '1行目
.Lines(2).Font.Size = 30 '2行目
.Lines(3).Font.Size = 20 '3行目
End With
Next

MsgBox "処理が終了しました。"

Set PpPrs = Nothing
Set PpApp = Nothing


End Sub
---------------------------------------

投稿日時 - 2010-07-08 13:11:32

QNo.6023881

困ってます

このQ&Aは役に立ちましたか?

5人が「このQ&Aが役に立った」と投票しています

回答(1)

ANo.1

前のご質問
http://okwave.jp/qa/q5994307.html
への回答と同様ですが、調査されたコードを生かすと下記の様にできます。
セルデータを一旦配列に入れたり、コードはより難しくなっていると思いますが。
前の質問はお閉め下さい。
Sub ExceltoPowerPoint()
Dim objRng As Range
Dim varRng As Variant
Dim intSNum As Integer
Dim i, j As Integer

Dim PpApp As PowerPoint.Application
Dim PpPrs As PowerPoint.Presentation
Dim PpSlide As PowerPoint.Slide
Dim PpShape As PowerPoint.Shape

Set objRng = Worksheets("Sheet1").Range("A1:C2")
varRng = objRng.Value
Set objRng = Nothing
Set PpApp = CreateObject("PowerPoint.Application")
Set PpPrs = PpApp.Presentations.Add
PpApp.Visible = True
For i = 1 To UBound(varRng, 1)
Set PpSlide = PpPrs.Slides.Add(i, ppLayoutBlank)
For j = 1 To UBound(varRng, 2)
Set PpShape = PpPrs.Slides(i).Shapes.AddTextbox(msoTextOrientationHorizontal, 30, 50 + 150 * (j - 1), 710, 140)
With PpShape.TextFrame.TextRange
.Text = CStr(varRng(i, j))
.Font.NameAscii = "Arial"
.Font.NameFarEast = "MS Pゴシック"
.Font.NameOther = "Arial"
.Lines(1).Font.Size = 30 '1行目
End With
Set PpShape = Nothing
Next
Set PpSlide = Nothing
Next
MsgBox "処理が終了しました。"
Set PpPrs = Nothing
Set PpApp = Nothing
End Sub

投稿日時 - 2010-07-08 22:55:37

あなたにオススメの質問