PPT终于能做动态图表了! excel表格3步轻松搞定动态图表的技巧

Dim Wb As Object, Sh As Object
' ========== 可修改的配置区域 ==========
Const DATA_RANGE As String = "A9:A10" ' 组合框数据源区域
Const OUTPUT_CELL As String = "C10" ' 结果输出单元格
Const SHEET_NAME As String = "演示" ' 工作表名称
' =====================================
' 初始化组合框
Private Sub InitializeComboBox()
On Error GoTo ErrorHandler
' 获取嵌入的Excel对象
Set Wb = GetExcelWorkbook()
If Wb Is Nothing Then Exit Sub
' 获取工作表
Set Sh = Wb.Worksheets(SHEET)
' 清空并填充组合框
With ComboBox1
.Clear
' 自动计算数据范围
Dim dataRange As Object
Set dataRange = Sh.Range(DATA_RANGE)
Dim cell As Object
For Each cell In dataRange
If Not IsEmpty(cell) Then
.AddItem cell.Value
End If
Next cell
' 设置下拉显示行数
If .ListCount > 0 Then
.ListRows = .ListCount
.ListIndex = 0 ' 选择第一项
' 将初始值写入输出单元格
Sh.Range(OUTPUT_CELL) = .Value
Else
MsgBox DATA_RANGE & "区域没有数据，请检查Excel文件"
End If
End With
Exit Sub
ErrorHandler:
MsgBox "初始化组合框时出错: " & Err.Description, vbExclamation
End Sub
' 安全获取Excel工作簿对象
Function GetExcelWorkbook() As Object
On Error GoTo ExcelError
Dim shp As Shape
For Each shp In Me.Shapes
If shp.Type = msoEmbeddedOLEObject Then
If shp.OLEFormat.ProgID Like "*Excel*" Then
Set GetExcelWorkbook = shp.OLEFormat.Object
Exit Function
End If
End If
Next shp
ExcelError:
MsgBox "未找到嵌入的Excel对象" & vbCrLf & _
"请确保:" & vbCrLf & _
"1. 已嵌入Excel对象" & vbCrLf & _
"2. 对象未被删除或损坏", vbExclamation
Set GetExcelWorkbook = Nothing
End Function
' 组合框值改变事件
Private Sub ComboBox1_Change()
On Error GoTo ChangeError
' 确保对象引用有效
If Wb Is Nothing Then
Set Wb = GetExcelWorkbook()
If Wb Is Nothing Then Exit Sub
End If
If Sh Is Nothing Then
Set Sh = Wb.Worksheets(SHEET_NAME)
End If
' 将选择的值写入Excel的输出单元格
If ComboBox1.ListIndex >= 0 Then
Sh.Range(OUTPUT_CELL) = ComboBox1.Value
End If
Exit Sub
ChangeError:
MsgBox "更新Excel数据时出错: " & Err.Description, vbExclamation
End Sub
' 幻灯片开始放映时初始化
Private Sub Slide_ShowBegin()
InitializeComboBox
End Sub
' 可选：点击组合框时确保初始化
Private Sub ComboBox1_GotFocus()
If ComboBox1.ListCount = 0 Then
InitializeComboBox
End If
End Sub
' 清理资源
Private Sub Slide_ShowEnd()
Set Sh = Nothing
Set Wb = Nothing
End Sub