如何调整VBA代码实现Excel 41组图表按新模式导入PPT

需求背景 #

原VBA代码基于每组37个图表的规则，按4,4,4,4,4,3,1,1,...的幻灯片图表数量模式重复生成PPT；现需调整为每组41个图表，并采用新的幻灯片图表数量模式：4,2,3,3,3,2,4,2,4,1,1,...（模式循环复用）。

原代码 #

Option Explicit

Sub CopyChartsToPowerPoint()

'// excel variables/objects
Dim wb As Workbook
Dim source_sheet As Worksheet
Dim chart_obj As ChartObject
Dim i As Long, last_row As Long, tracker As Long

'// powerpoint variables/objects
Dim pp_app As PowerPoint.Application
Dim pp_presentation As Presentation
Dim pp_slide As Slide
Dim pp_shape As Object
Dim pp_slider_tracker As Long

Set wb = ThisWorkbook
Set source_sheet = wb.Worksheets("portfolio_charts")
Set pp_app = New PowerPoint.Application
Set pp_presentation = pp_app.Presentations.Add

last_row = source_sheet.Cells(Rows.Count, "A").End(xlUp).Row
pp_slider_tracker = 1

Set pp_slide = pp_presentation.Slides.Add(pp_slider_tracker, ppLayoutBlank)

For i = 1 To last_row

If i Mod 37 = 5 Or i Mod 37 = 9 Or i Mod 37 = 13 Or i Mod 37 = 17 _
Or i Mod 37 = 21 Or (i Mod 37 > 23 And i Mod 37 < 37) Or i Mod 37 = 0 Or (i Mod 37 = 1 And pp_slider_tracker > 1) Then
pp_slider_tracker = pp_slider_tracker + 1
Set pp_slide = pp_presentation.Slides.Add(pp_slider_tracker, ppLayoutBlank)
End If

Set chart_obj = source_sheet.ChartObjects(source_sheet.Cells(i, "A").Value)
chart_obj.Chart.ChartArea.Copy

'Set pp_shape = pp_slide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
Set pp_shape = pp_slide.Shapes.Paste

Select Case i Mod 37

Case 1, 5, 9, 13, 17
pp_shape.Left = 66
pp_shape.Top = 86

Case 2, 6, 10, 14, 18
pp_shape.Left = 510
pp_shape.Top = 86

Case 3, 7, 11, 15, 19
pp_shape.Left = 66
pp_shape.Top = 296

Case 4, 8, 12, 16, 20
pp_shape.Left = 510
pp_shape.Top = 296

Case 21
pp_shape.Left = 66
pp_shape.Top = 86

Case 22
pp_shape.Left = 510
pp_shape.Top = 86

Case 23
pp_shape.Left = 66
pp_shape.Top = 296

Case 24 To 37, 0
pp_shape.Left = 192
pp_shape.Top = 90
pp_shape.width = 576
pp_shape.height = 360

End Select

Application.Wait (Now + TimeValue("00:00:01"))

Next i

End Sub

修改后的代码 #

Option Explicit

Sub CopyChartsToPowerPoint()

'// excel variables/objects
Dim wb As Workbook
Dim source_sheet As Worksheet
Dim chart_obj As ChartObject
Dim i As Long, last_row As Long
Dim group_pos As Long
Dim slide_mode_counts As Variant
Dim slide_total As Long, current_slide_idx As Long

'// powerpoint variables/objects
Dim pp_app As PowerPoint.Application
Dim pp_presentation As Presentation
Dim pp_slide As Slide
Dim pp_shape As Object
Dim pp_slider_tracker As Long

Set wb = ThisWorkbook
Set source_sheet = wb.Worksheets("portfolio_charts")
Set pp_app = New PowerPoint.Application
Set pp_presentation = pp_app.Presentations.Add

' 定义新的幻灯片图表数量模式：4,2,3,3,3,2,4,2,4,1,1
slide_mode_counts = Array(4, 2, 3, 3, 3, 2, 4, 2, 4, 1, 1)
last_row = source_sheet.Cells(Rows.Count, "A").End(xlUp).Row
pp_slider_tracker = 1

Set pp_slide = pp_presentation.Slides.Add(pp_slider_tracker, ppLayoutBlank)
current_slide_idx = 0
slide_total = slide_mode_counts(current_slide_idx)

For i = 1 To last_row
    ' 计算当前在41个图表组内的位置（1-41）
    group_pos = ((i - 1) Mod 41) + 1
    
    ' 判断是否需要新增幻灯片：当前组内位置超出当前幻灯片容量，或新组的第一个图表且不是初始幻灯片
    If (group_pos > slide_total) Or (group_pos = 1 And pp_slider_tracker > 1) Then
        pp_slider_tracker = pp_slider_tracker + 1
        Set pp_slide = pp_presentation.Slides.Add(pp_slider_tracker, ppLayoutBlank)
        ' 循环切换到下一个幻灯片模式
        current_slide_idx = (current_slide_idx + 1) Mod UBound(slide_mode_counts)
        slide_total = slide_mode_counts(current_slide_idx)
        ' 新幻灯片的第一个图表，重置组内位置计数
        group_pos = 1
    End If

    Set chart_obj = source_sheet.ChartObjects(source_sheet.Cells(i, "A").Value)
    chart_obj.Chart.ChartArea.Copy

    'Set pp_shape = pp_slide.Shapes.PasteSpecial(ppPasteEnhancedMetafile)
    Set pp_shape = pp_slide.Shapes.Paste

    ' 根据当前幻灯片的图表容量设置布局坐标
    Select Case slide_total
        ' 单张幻灯片放4个图表的布局
        Case 4
            Select Case group_pos
                Case 1: pp_shape.Left = 66: pp_shape.Top = 86
                Case 2: pp_shape.Left = 510: pp_shape.Top = 86
                Case 3: pp_shape.Left = 66: pp_shape.Top = 296
                Case 4: pp_shape.Left = 510: pp_shape.Top = 296
            End Select
        
        ' 单张幻灯片放3个图表的布局
        Case 3
            Select Case group_pos
                Case 1: pp_shape.Left = 66: pp_shape.Top = 86
                Case 2: pp_shape.Left = 300: pp_shape.Top = 180
                Case 3: pp_shape.Left = 510: pp_shape.Top = 296
            End Select
        
        ' 单张幻灯片放2个图表的布局
        Case 2
            Select Case group_pos
                Case 1: pp_shape.Left = 192: pp_shape.Top = 86
                Case 2: pp_shape.Left = 192: pp_shape.Top = 296
            End Select
        
        ' 单张幻灯片放1个图表的布局
        Case 1
            pp_shape.Left = 192
            pp_shape.Top = 90
            pp_shape.Width = 576
            pp_shape.Height = 360
    End Select

    Application.Wait (Now + TimeValue("00:00:01"))

Next i

End Sub

核心修改说明 #

• 替换分组基数：将原代码硬编码的37替换为41，通过group_pos = ((i - 1) Mod 41) + 1计算每组内的图表位置
• 动态管理幻灯片模式：用数组slide_mode_counts存储新的图表数量模式，通过current_slide_idx循环切换模式，避免硬编码判断
• 重构幻灯片切换逻辑：不再依赖Mod值的硬编码判断，而是通过当前幻灯片的容量slide_total自动触发新幻灯片创建，逻辑更清晰易维护
• 适配多布局坐标：针对4/3/2/1个图表的幻灯片分别定义布局坐标，确保排版符合需求

内容的提问来源于stack exchange，提问作者BHF