Dim Wb As Object, Sh As Object
' ========== 可修改的配置區(qū)域 ==========
Const DATA_RANGE As String = "A9:A10" ' 組合框數(shù)據(jù)源區(qū)域
Const OUTPUT_CELL As String = "C10" ' 結(jié)果輸出單元格
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
' 自動計算數(shù)據(jù)范圍
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
' 設(shè)置下拉顯示行數(shù)
If .ListCount > 0 Then
.ListRows = .ListCount
.ListIndex = 0 ' 選擇第一項
' 將初始值寫入輸出單元格
Sh.Range(OUTPUT_CELL) = .Value
Else
MsgBox DATA_RANGE & "區(qū)域沒有數(shù)據(jù)，請檢查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數(shù)據(jù)時出錯: " & 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