时间戳

首页 > 解决方案 > 对多个复制粘贴功能的编码建议：为每个或全部创建一个新模块到一个代码中？

excel - 对多个复制粘贴功能的编码建议：为每个或全部创建一个新模块到一个代码中？

问题描述

祝大家星期天快乐。我需要一些关于什么是继续编写代码的最佳方法的建议——我担心以某种方式保持它的流畅和简单（该文件是一个 20MB 的文件）。我有以下编码（感谢@BigBen）。刷新后，它将一个工作表中的产品游戏 (x8) 复制粘贴到 ppt 中。我可以从“C1：AE37”范围内将相同的逻辑复制到工作表“B”

您是否建议为每张工作表使用一个新模块？- 或者我可以升级下面的编码，比如一个询问要导出什么的文本框（选择工作表 A、工作表 B 等），然后循环if回到每个复制粘贴工作表范围到 ppt 幻灯片？哪些更有效地保持 Excel 流畅？非常感谢您的帮助。

Option Explicit
Sub ExportToPPT()

Dim ppApp As PowerPoint.Application
Set ppApp = New PowerPoint.Application

Dim ppFileName As String
ppFileName = "C:\Users\\Desktop\Financial Summary.pptx"

Dim ppPres As PowerPoint.Presentation
Set ppPres = ppApp.Presentations.Open(filename:=ppFileName)

Dim ppSlide As PowerPoint.Slide

Dim i As Integer
For i = 2 To 9
    Set ppSlide = ppPres.Slides(i)

    Dim j As Integer
    For j = ppSlide.Shapes.Count To 1 Step -1
        If ppSlide.Shapes(j).Type = msoPicture Then
            ppSlide.Shapes(j).Delete
        End If
    Next j
Next i

Dim Sel As Range
Dim source As Range
Dim l As Long

For l = 8 To 1 Step -1
Workbooks("WWDWT.xlsm").Sheets("Graph Data").Range("E4").Value = l
Application.Calculate

Set source = ActiveWorkbook.Sheets("A").Range("D1")
ActiveWorkbook.Sheets("A").Range("D1:AF40").Copy

Set ppSlide = ppPres.Slides(l + 1)
ppSlide.Shapes.PasteSpecial ppPasteBitmap
Next l
End Sub

标签： excelvba

解决方案

我只是参数化所有的东西，像这样：

Option Explicit
Sub ExportToPPT(ppFileName As String, xlFileName as String, xlCalculationSheetName as String, xlDataSheetName)

Dim ppApp As PowerPoint.Application
Set ppApp = New PowerPoint.Application

Dim ppPres As PowerPoint.Presentation
Set ppPres = ppApp.Presentations.Open(filename:=ppFileName)

Dim ppSlide As PowerPoint.Slide

Dim i As Integer
For i = 2 To 9
    Set ppSlide = ppPres.Slides(i)

    Dim j As Integer
    For j = ppSlide.Shapes.Count To 1 Step -1
        If ppSlide.Shapes(j).Type = msoPicture Then
            ppSlide.Shapes(j).Delete
        End If
    Next j
Next i

Dim Sel As Range
Dim source As Range
Dim l As Long

For l = 8 To 1 Step -1
Workbooks(xlFileName).Sheets(xlCalculationSheetName).Range("E4").Value = l
Application.Calculate

Set source = ActiveWorkbook.Sheets(xlCalculationSheetName).Range("D1")
ActiveWorkbook.Sheets(xlCalculationSheetName).Range("D1:AF40").Copy

Set ppSlide = ppPres.Slides(l + 1)
ppSlide.Shapes.PasteSpecial ppPasteBitmap
Next l
End Sub

根据需要参数化更多的东西。

推荐阅读