Word用户窗体加载时触发Run-Time Error 381：List属性设置失败

错误触发原因 #

1. 无效数组初始化：当外部Excel的Sheet2数据行数≤1或列数≤1时，代码中ReDim arr(1 To UBound(arrData)-1)或ReDim arr(1 To UBound(arrData,2)-1)会生成下界大于上界的无效数组，给ComboBox的List属性赋值时直接触发381错误。
2. 重复加载数据：UserForm_Initialize中先调用LoadData加载数据，随后又重新打开Excel文件重复给CompanyName.List赋值，既冗余又可能导致Excel进程残留。
3. 赋值语法错误：SigName.List = xlBook.Sheets("Sheet3").Range("A2:A29")直接赋值Range对象，ComboBox的List属性需要的是值数组，而非Range对象。
4. 无空值判断：若Sheet2的UsedRange为空，arrData会变成Empty，后续调用UBound会直接报错。

修复步骤与修正代码 #

1. 全局变量与LoadData过程修正 #

确保arrData加载后有有效数据，且Excel进程正确释放：

Option Explicit
Private oVars As Variables
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim c As Excel.Range
Dim arrData As Variant

Sub LoadData()
    Dim isNewApp As Boolean
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
        isNewApp = True
    End If
    On Error GoTo 0
    
    Set xlBook = xlApp.Workbooks.Open("FileName.xlsx")
    ' 仅当UsedRange有数据时才赋值，避免Empty数组
    If Not xlBook.Sheets(2).UsedRange Is Nothing Then
        arrData = xlBook.Sheets(2).UsedRange.Value
    End If
    xlBook.Close False
    If isNewApp Then xlApp.Quit
    ' 释放对象
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

2. UserForm_Initialize过程修正 #

移除重复加载逻辑，从arrData提取数据，添加数组有效性判断：

Private Sub UserForm_Initialize()
    Call LoadData
    Dim arr(), i As Long
    
    ' 给CompanyName赋值：先判断arrData是否有效且行数≥2
    If IsArray(arrData) And UBound(arrData) >= 2 Then
        ReDim arr(1 To UBound(arrData) - 1)
        For i = 2 To UBound(arrData)
            arr(i - 1) = arrData(i, 1)
        Next
        Me.CompanyName.List = arr
    End If
    
    ' 初始化控件文本
    Caption = "Fill Me Out Please"
    Label1.Caption = "Company Name"
    Label2.Caption = "Attention of"
    Label3.Caption = "Signature"
    Label4.Caption = "Drawings"
    Label5.Caption = "Calculation"
    Label6.Caption = "Design Criteria Number"
    Label7.Caption = "Rev"
    Label8.Caption = "Rev"
    Label9.Caption = "Design Criteria Dotpoints"
    Label10.Caption = "Exclusions"
    
    CommandButton1.Caption = "OK"
    CommandButton2.Caption = "Cancel"
    
    ' 加载SigName数据：直接打开一次Excel获取，避免重复
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlBook = xlApp.Workbooks.Open("FileName.xlsx")
    ' 添加.Value获取值数组
    Me.SigName.List = xlBook.Sheets("Sheet3").Range("A2:A29").Value
    xlBook.Close savechanges:=False
    xlApp.Quit
    ' 释放对象
    Set xlBook = Nothing
    Set xlApp = Nothing
End Sub

3. CompanyName_Change过程修正 #

添加数组有效性判断，避免无效数组初始化：

Private Sub CompanyName_Change()
    Me.Attention.Clear
    Dim sCom As String: sCom = Me.CompanyName.Value
    Dim i As Long, j As Long, r As Long, arr()
    
    ' 先判断arrData是否为有效数组，且行数、列数≥2
    If Not IsArray(arrData) Or UBound(arrData) < 2 Or UBound(arrData, 2) < 2 Then Exit Sub
    
    For i = 2 To UBound(arrData)
        If sCom = arrData(i, 1) Then
            ' 动态初始化数组，避免固定长度导致的索引问题
            ReDim arr(1 To UBound(arrData, 2) - 1)
            r = 0
            For j = 2 To UBound(arrData, 2)
                If Len(arrData(i, j)) > 0 Then
                    r = r + 1
                    arr(r) = arrData(i, j)
                Else
                    Exit For
                End If
            Next
            If r > 0 Then
                ReDim Preserve arr(1 To r)
                Me.Attention.List = arr
            End If
            ' 找到匹配公司后退出循环，提升效率
            Exit For
        End If
    Next
End Sub

4. CommandButton1_Click过程修正 #

添加对象释放，避免Excel进程残留：

Private Sub CommandButton1_Click()
    Set oVars = ActiveDocument.Variables
    
    On Error Resume Next
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Set xlApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
    Set xlBook = xlApp.Workbooks.Open("FileName.xlsx")
    
    Set c = xlBook.Sheets("Sheet1").Cells.Find(what:=Me.CompanyName.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        oVars("CompanyName").Value = c.Value
        oVars("Address").Value = c.Offset(0, 1).Value
        oVars("Suburb").Value = c.Offset(0, 2).Value
        oVars("State").Value = c.Offset(0, 3).Value
        oVars("PostCode").Value = c.Offset(0, 4).Value
    End If
    
    Set c = xlBook.Sheets("Sheet3").Cells.Find(what:=Me.SigName.Value, LookIn:=xlValues, LookAt:=xlWhole)
    If Not c Is Nothing Then
        oVars("SigName").Value = c.Value
        oVars("Position").Value = c.Offset(0, 1).Value
        oVars("Qualification").Value = c.Offset(0, 2).Value
    End If
    
    xlBook.Close savechanges:=False
    xlApp.Quit
    ' 释放对象
    Set c = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    
    ActiveDocument.Fields.Update
    Set oVars = Nothing
    Unload Me
End Sub

5. CommandButton2_Click过程（无修改） #

Private Sub CommandButton2_Click()
    'User has cancelled so unload the form
    Unload Me
End Sub

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