Excel VBA中Application.Transpose在另一台64位Windows机器失效问题

原始表格样式：

代码输出的表格样式：

目标汇总表需要实现以下功能：

• 统计“old”状态的出现次数
• 统计“new”状态的出现次数
• 将所有唯一的old组汇总至单个单元格
• 将所有唯一的new组汇总至单个单元格

以下VBA代码在一台64位Windows机器上可正常运行，但在另一台同配置机器上失效，问题出在Application.Transpose语句：

Sub TableSummary()
    Dim sht As Worksheet
    Dim i As Integer
    Dim tbl As ListObject
    Dim new_tbl As ListObject, old_tbl As ListObject
    Dim new_array As Variant, old_array As Variant
    
    '禁用屏幕更新与事件，避免弹窗干扰
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Application.DisplayAlerts = False
    On Error Resume Next
    Application.DisplayAlerts = True
    
    '在汇总工作表添加新的汇总表
    With ActiveWorkbook
        sht.ListObjects.Add(xlSrcRange, sht.UsedRange, , xlYes).Name = "Summary"
        sht.ListObjects("Summary").TableStyle = "TableStyleMedium5"
    End With

    i = 1
    For Each sht In ActiveWorkbook.Worksheets
        If sht.Name = "Summary" Then
            '设置汇总表列标题
            sht.Cells(1, 4).Resize(1, 4).Value = Array("Nbr of old", "Nbr of new", "Groups old", "Groups new")
        
            i = i + 1
            
            For Each tbl In sht.ListObjects
                '针对蓝色样式表格（TableStyleMedium2）处理
                If tbl.TableStyle = "TableStyleMedium2" Then
                    sht.Range("D" & i).Value = WorksheetFunction.CountIf(tbl.Range, "old")
                    sht.Range("E" & i).Value = WorksheetFunction.CountIf(tbl.Range, "new")
        
                    Set new_tbl = sht.ListObjects("Summary")
                    Set new_tbl = sht.ListObjects("Summary").Range().AutoFilter(Field:=2, Criteria1:="old")
                    new_array = Application.Transpose(WorksheetFunction.Unique(sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible))) '此语句在另一台机器失效
                    sht.Range("F" & i).Value = Join(new_array, ", ") 
        
                    sht.ListObjects("Summary").AutoFilter.ShowAllData
                    Set new_tbl = sht.ListObjects("Summary")
                    Set new_tbl = sht.ListObjects("Summary").Range().AutoFilter(Field:=2, Criteria1:="new")
                    new_array = Application.Transpose(WorksheetFunction.Unique(sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible))) '此语句在另一台机器失效
                    sht.Range("G" & i).Value = Join(new_array, ", ") 
        
                    sht.ListObjects("Summary").AutoFilter.ShowAllData
                    
                End If
            Next
        End If
    Next
End Sub

Application.Transpose在不同Excel环境下可能因版本差异、数组维度限制出现兼容性问题，可通过以下两种方式替代：

方案1：替换为WorksheetFunction.Transpose #

将出错的两行代码替换为：

new_array = WorksheetFunction.Transpose(WorksheetFunction.Unique(sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible)))

WorksheetFunction.Transpose的兼容性更强，部分环境下比Application.Transpose更稳定。

方案2：手动遍历收集唯一值，避开转置操作 #

如果转置问题依然存在，可直接遍历可见单元格收集唯一值后拼接，完全避开转置逻辑：

'处理old组唯一值拼接
Dim cell As Range
Dim uniqueOldGroups As Collection
Set uniqueOldGroups = New Collection
On Error Resume Next
For Each cell In sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible)
    uniqueOldGroups.Add cell.Value, Key:=CStr(cell.Value)
Next
On Error GoTo 0
'拼接成字符串
Dim oldGroupsStr As String
For Each item In uniqueOldGroups
    oldGroupsStr = oldGroupsStr & ", " & item
Next
sht.Range("F" & i).Value = Mid(oldGroupsStr, 3) '移除开头多余的", "

'处理new组唯一值拼接（逻辑同上）
Dim uniqueNewGroups As Collection
Set uniqueNewGroups = New Collection
On Error Resume Next
For Each cell In sht.ListObjects("Summary").ListColumns("Group").DataBodyRange.SpecialCells(xlCellTypeVisible)
    uniqueNewGroups.Add cell.Value, Key:=CStr(cell.Value)
Next
On Error GoTo 0
Dim newGroupsStr As String
For Each item In uniqueNewGroups
    newGroupsStr = newGroupsStr & ", " & item
Next
sht.Range("G" & i).Value = Mid(newGroupsStr, 3)

额外优化提示 #

原代码中Set new_tbl = sht.ListObjects("Summary").Range().AutoFilter(...)属于无效赋值，AutoFilter不返回ListObject对象，可直接删除这两行冗余代码。

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