修剪Excel VBA，将数据从各个选项卡复制到Powerpoint

6ie5vjzr  于 2023-01-27  发布在  其他
关注(0)|答案(2)|浏览(167)

我基本上是在寻找一种方法来修剪下面的代码。代码工作得很好。这段代码从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

我拿了一些零碎的东西，修剪了一下，但我觉得还有更多的空间。

excel

2条答案

按热度按时间
anauzrmj

anauzrmj1#

这个新版本的代码使用了两个数组，一个用于工作表名称，另一个用于幻灯片标题。它还使用了一个循环来遍历工作表和标题。这样，您就不需要多次重复相同的代码。
还删除了未使用的变量，并将字体名称设置为字符串。

Sub CommercialtoPowerPoint()

    'declare variables
    Dim PP As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPslide As PowerPoint.Slide
    Dim Sh As PowerPoint.Shape
    Dim slideTitle As String

    'opening powerpoint and creating a new presentation
    Set PP = New PowerPoint.Application
    Set PPPres = PP.Presentations.Add
    PP.Visible = True

    'setting slide size from 16:9 to 4:3
    PPPres.PageSetup.SlideSize = 1

    'Array of sheet names
    Dim sheetNames() As String
    sheetNames = Array("Commercial-H1", "Commercial-LAM", "Commercial-EMEA")

    'Array of slide titles
    Dim slideTitles() As String
    slideTitles = Array("H1 P&L", "LAM P&L", "EMEA P&L")

    'loop through the sheets
    For i = 0 To UBound(sheetNames)
        'adding new slide to PP presentation and using for further use
        Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
        PPslide.Select

        'code to copy range from excel sheet
        Sheets(sheetNames(i)).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

        'Adding title to slide and align center
        slideTitle = slideTitles(i)
        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
    Next i
    Application.CutCopyMode = False
End Sub
赞(0）分享  回复(0）举报  2023-01-27
vhipe2zx

vhipe2zx2#

我想通了。@德语代码是好的，但需要2个变化如下：
声明（此处缺失）

Dim i As Integer

并更改下面两行

Dim sheetNames() As String

这需要

Dim sheetNames() As Variant

以及

Dim slideTitles() As String

必须是

Dim slideTitles() As Variant

轻微的纠正和这解决了问题!

赞(0）分享  回复(0）举报  2023-01-27
我来回答

相关问题

    查看更多

    热门标签

    更多
    JavaquerypythonNode开发语言requestUtil数据库Table后端算法LoggerMessageElementParser

    最新问答

    更多
    • 蜀ICP备2022004421号-2 NULL123 https://www.null123.com © All rights reserved
    • 本站内容来源互联网,如果侵犯您的权益请联系我们删除, 联系方式：448109455@qq.com