ExcelVBA將過濾后的列作為字串轉置到單元格

我有一張看起來像這樣的桌子

現在我寫了一個代碼，它給了我這樣的輸出：

所以目標是有一個結果表，它執行以下操作：

• 計數“舊”狀態出現的次數
• 計算“新”狀態出現的次數
• 在一個單元格中獲取所有（唯一）舊組
• 在一個單元格中獲取所有（唯一）新組

我嘗試了以下代碼，該代碼在一臺計算機上運行，??但在我的另一臺計算機上不起作用（均為 Windows，64 位）：

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
    
    '2. Disable Screen Updating - stop screen flickering and Disable Events to avoid inturupted dialogs / popups
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Application.DisplayAlerts = False
    On Error Resume Next
    Application.DisplayAlerts = True
    
    '4. Add a new summary table to summary worksheet
    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
            'Define Column Headers of Summary
            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
                ' Blue table
                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))) 'This doesn't work on my other machine
                    sht.Range("F" & i).Value = Join(new_array, ", ") 'works!
                    'Debug.Print 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))) 'This doesn't work on my other machine
                    sht.Range("G" & i).Value = Join(new_array, ", ") 'works!
                    Debug.Print Join(new_array, ", ")
        
                    sht.ListObjects("Summary").AutoFilter.ShowAllData
                    
                End If
        Next
        End If
    Next
End Sub

Application.Transpose在我的第二臺機器上不起作用，我完全不知道為什么。如果有人可以幫助我，將非常非常感謝！

uj5u.com熱心網友回復：

這是使用函式創建唯一值串列的另一種方法：

Sub TableSummary()
    Const NEW_OLD_COL As Long = 2
    Const GROUP_COL As String = "Group"
    Const VAL_OLD As String = "old"
    Const VAL_NEW As String = "new"
    
    Dim sht As Worksheet, DstSht 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
    
    Set sht = ActiveSheet 'or whatever...
    Set DstSht = sht
    i = 2
    
    For Each tbl In sht.ListObjects
        ' Blue table
        If tbl.TableStyle = "TableStyleMedium2" Then
            
            With tbl.ListColumns(NEW_OLD_COL)
                DstSht.Range("G" & i).Value = WorksheetFunction.CountIf(.DataBodyRange, VAL_OLD)
                DstSht.Range("H" & i).Value = WorksheetFunction.CountIf(.DataBodyRange, VAL_NEW)
            End With
            
            tbl.Range.AutoFilter Field:=NEW_OLD_COL, Criteria1:="new"
            DstSht.Range("I" & i).Value = VisibleUniques(tbl, GROUP_COL)
            tbl.Range.AutoFilter
    
            tbl.Range.AutoFilter Field:=NEW_OLD_COL, Criteria1:="old"
            DstSht.Range("J" & i).Value = VisibleUniques(tbl, GROUP_COL)
            tbl.Range.AutoFilter
            i = i   1
        End If
    Next
End Sub

'Return a comma-separated list of all unique values in visible cells in 
'   column `ColName` of listobject `tbl`
Function VisibleUniques(tbl As ListObject, ColName As String) As String
    Dim rngVis As Range, dict As Object, c As Range
    On Error Resume Next 'ignore error if no visible cells
    Set rngVis = tbl.ListColumns(ColName).DataBodyRange.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0      'stop ignoring errors
    If rngVis Is Nothing Then Exit Function
    Set dict = CreateObject("scripting.dictionary")
    For Each c In rngVis.Cells
        dict(CStr(c.Value)) = True
    Next c
    VisibleUniques = Join(dict.keys, ", ")
End Function

標籤：数组擅长vba转置

上一篇：如果單元格不包含命名串列中的值

下一篇：呼叫函式時出現“無效的程序呼叫或引數”錯誤