Excel VBA遍历表格表头与单元格功能异常求助

问题1：表头转移后循环中断 #

根源 #

1. 行号提取逻辑错误：selectRow = Right(ArtRange, 1)仅支持1位数行号，若ArtRange是B10这类两位数行号，会导致selectRow取到错误值，进而生成无效单元格地址（如C/），触发错误中断循环。
2. 空数组未做判断：未启用单元格获取循环时，cellNames为空集合，转换的cellArr是空数组，若List.CreateDropDown不支持空参数，会触发错误中断程序。

修复方法 #

• 改用Range(ArtRange).Row获取行号，适配多位数行号场景：

  selectRow = CStr(Worksheets(1).Range(ArtRange).Row)
  headerRow = CStr(Worksheets(1).Range(ArtRange).Row - 1)
  

• 在调用下拉列表创建方法前，判断集合是否有数据，避免无效调用：

  If cellNames.Count > 0 Then
      cellArr = cellNames.ToArray
      Call List.CreateDropDown(selectCol & headerRow, cellArr)
  End If
  

问题2：获取单元格时触发「下标越界」错误 #

根源 #

1. 列索引类型错误：tbl.ListColumns(header)中header是Range对象，但ListColumns仅接受列名字符串或列序号数字作为索引，直接传入Range会导致下标越界。
2. 未判断数据区域是否存在：若表格仅含表头无数据行，DataBodyRange为Nothing，直接访问会触发错误。

修复方法 #

• 使用header.Value（列名）或header.Column - tbl.Range.Column + 1（列序号）作为合法索引：

  Set col = tbl.ListColumns(header.Value) ' 通过列名获取列对象
  

• 先判断数据区域是否存在，再执行遍历：

  If Not col.DataBodyRange Is Nothing Then
      For Each cell In col.DataBodyRange
          If Not IsEmpty(cell.Value) Then cellNames.Add cell.Value
      Next cell
  End If
  

完整修复后的代码 #

Option Explicit

Sub GetCellNames(CatRange As String, ArtRange As String)
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim cellNames As Object
    Dim cellArr As Variant
    Dim tblName As String
    Dim headerRow As String
    Dim selectRow As String
    Dim selectCol As String
    Dim header As Range
    Dim cell As Range
    Dim col As ListColumn
    
    ' 明确指定工作表，避免依赖活动表导致的引用错误
    Set ws = Worksheets(Worksheets(1).Range(CatRange).Value)
    tblName = Worksheets(1).Range(ArtRange).Value
    Set tbl = ws.ListObjects(tblName)
    Set cellNames = CreateObject("System.Collections.ArrayList")
    
    ' 正确提取列标识和行号，支持多位数行号
    selectCol = Chr(Asc(Left(ArtRange, 1)) + 1)
    selectRow = CStr(Worksheets(1).Range(ArtRange).Row)
    headerRow = CStr(Worksheets(1).Range(ArtRange).Row - 1)

    ' 遍历表头单元格
    For Each header In tbl.HeaderRowRange.Cells
        If Not Right(header.Value, 1) = "2" Then
            ' 1. 转移表头名称到目标单元格
            Worksheets(1).Range(selectCol & headerRow).Value = header.Value

            ' 2. 获取非空单元格名称
            Set col = tbl.ListColumns(header.Value)
            If Not col.DataBodyRange Is Nothing Then
                For Each cell In col.DataBodyRange
                    If Not IsEmpty(cell.Value) Then cellNames.Add cell.Value
                Next cell
            End If

            ' 仅当有数据时创建下拉列表
            If cellNames.Count > 0 Then
                cellArr = cellNames.ToArray
                Call List.CreateDropDown(selectCol & selectRow, cellArr)
            End If
            
            ' 清空集合，避免不同列数据污染
            cellNames.Clear
            ' 切换到下一列
            selectCol = Chr(Asc(selectCol) + 1)
        End If
    Next header
End Sub

额外优化点：

• 新增cellNames.Clear，确保每列数据独立不干扰
• 所有Range引用均明确指定工作表，避免活动表切换引发的隐性错误

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