我基本上是在寻找一种方法来修剪下面的代码。代码工作得很好。这段代码从Excel的每个标签页中提取一个范围,并将其粘贴到PowerPoint中,然后在粘贴后为每张幻灯片分配一个标题,但我觉得代码太长了,可以修剪。我使用Excel 2016。另外值得一提的是,无论哪里都说重复,它基本上是重复复制和粘贴从excel标签到powerpoint,然后分配一个标题给该幻灯片。
Sub CommercialtoPowerPoint()
'declare variables
Dim otherWB As Workbook
Dim ws As Worksheet
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPslide As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim Bh As PowerPoint.Shape
Dim GSF As Workbook
Dim SlideTitle As String
'opening powerpoint and creating a new presentation
Set GSF = Workbooks("Support Function P&L Details FY23-Update File")
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'adding new slide to PP presentation and using for further use
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
'setting slide size from 16:9 to 4:3
PPslide.Application.ActivePresentation.PageSetup.SlideSize = 1 'ppSlideSizeOnScreen = 1
'code to copy range from excel sheet
Sheets("Commercial-H1").Select
Sheets("Commercial-H1").Range("B3:L220").Copy
'pasting picture and adjusting positing
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
'Adding title to slide and align center
SlideTitle = "H1 P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-LAM").Select
Sheets("Commercial-LAM").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "LAM P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-EMEA").Select
Sheets("Commercial-EMEA").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "EMEA P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-APAC").Select
Sheets("Commercial-APAC").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "APAC P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-HS Admin").Select
Sheets("Commercial-HS Admin").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "HS Admin P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-Corp").Select
Sheets("Commercial-Corp").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "Corp P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-all").Select
Sheets("Commercial-all").Range("B3:L220").Copy
With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
.Width = 666.72
.Height = 390.24
End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "Full P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'Adding slide for Headcount and moving to last slide
Dim slideCount As Long
slideCount = PPPres.Slides.Count
Set PPslide = PPPres.Slides.Add(slideCount + 1, ppLayoutTitleOnly)
PPslide.Select
PPslide.Shapes(1).TextFrame.TextRange.Text = "Headcount"
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
'setting powerpoint title
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitle)
PPslide.Select
PPslide.Shapes(1).TextFrame.TextRange.Text = "Monthly P&L Report"
PPslide.Shapes(2).TextFrame.TextRange.Text = "Commercial"
'back to excel sheet and select cell A1 in every sheet
GSF.Activate
Application.CutCopyMode = False
For Each ws In GSF.Sheets
ws.Activate
ws.[a1].Select
Next ws
GSF.Worksheets(1).Activate
'powerpoint memory cleanup
PP.Activate
Set PPslide = Nothing
Set PPPres = Nothing
Set PP = Nothing
Set Sh = Nothing
Set Bh = Nothing
Set GSF = Nothing
End Sub
我拿了一些零碎的东西,修剪了一下,但我觉得还有更多的空间。
2条答案
按热度按时间anauzrmj1#
这个新版本的代码使用了两个数组,一个用于工作表名称,另一个用于幻灯片标题。它还使用了一个循环来遍历工作表和标题。这样,您就不需要多次重复相同的代码。
还删除了未使用的变量,并将字体名称设置为字符串。
vhipe2zx2#
我想通了。@德语代码是好的,但需要2个变化如下:
声明(此处缺失)
并更改下面两行
这需要
以及
必须是
轻微的纠正和这解决了问题!