连接可见单元格、删除重复项的公式

Question

TL;DR：我需要一个公式来连接可见单元格、删除重复项并在值之间添加“,”。

我有一个电子表格，我一直都有宏过滤并运行数据拉取。

第 3 行包含从 A6:S16627 中的数据集中提取特定指标的公式。

第 3 行中的一个单元格调用 VBA 脚本来运行该脚本连接可见单元格，并返回一个删除重复项的值。

例如，如果数据为 100、100、101、102、101，则返回“100、101、102”。

我的困难是，当父宏运行通过自动过滤器并将第 3 行复制+粘贴到另一张纸上时，此脚本无法有效刷新。

有没有办法将下面的脚本复制为 excel 公式，适用于我上面提供的场景？

Public Function MakeList(myRange As Range)
Dim c As Range, MyDict As Object

    Set MyDict = CreateObject("Scripting.Dictionary")
    On Error Resume Next
    For Each c In myRange
        If Rows(c.Row).Hidden = False Then
            MyDict.Add c.Value, 1
        End If
    Next c

    MakeList = Join(MyDict.keys, ", ")

End Function

感谢您提供的任何帮助。

编辑：

这是与上面代码交互的第二个代码。

Option Explicit

Sub VBAFilterCopyPaste()
    Dim cell As Range 'loop range
    Dim Rng As Range 'range for unique values

    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Dim ws3 As Worksheet

    Dim lRow As Long 'last row in RegionSummary
    Dim i As Integer 'counter

    Set ws1 = Worksheets("WAP")
    Set ws2 = Worksheets("HCAsummary")
    Set ws3 = Worksheets("NamedRange")

    Application.ScreenUpdating = False

    'reset autofilter
    ws1.ListObjects("Table2").Range.AutoFilter

    'autofilter on project selected
    ws1.ListObjects("Table2").Range.AutoFilter Field:=1, Criteria1:=ws2.Range("Q6")

    'copy Column B in Table2 to named Range I1
    ws1.Range("B5:B16627").SpecialCells(xlVisible).Copy 'extend 16627 this if needed
    ws3.Range("i1").PasteSpecial

    'Remove duplicates for unique values
    ws3.Columns("I:I").RemoveDuplicates Columns:=1, Header:=xlYes

    'set range for loop and sort
    Set Rng = ws3.Range("i2:i" & ws3.Cells(Rows.Count, "i").End(xlUp).Row)
    Rng.Sort Key1:=ws3.Range("I1"), Order1:=xlAscending

    lRow = 11 'set current last row for start of HCASummary

    'loop to copy row 3 from ws1 to ws2

    For Each cell In Rng
        'increment last row
        i = i + 1

        With ws1
            .ListObjects("Table2").Range.AutoFilter Field:=2, Criteria1:=cell.Value
            .Range("A3:S3").Copy
            ws2.Range("a" & lRow + i).PasteSpecial xlPasteValues
        End With

    Next

    'goto ws2.Range A11
    Application.Goto ws2.Range("A11")

    Application.ScreenUpdating = True

End Sub

Answer 1

我真的不明白你的意思

this script does not refresh effectively when a parent macro runs through the autofilter and copy+paste's row 3 onto another sheet.

你可能想详细说明一下

与此同时，您可以测试这个小小的重构：

Public Function MakeList(myRange As Range)
    Application.Volatile
    Dim c As Range

    With CreateObject("Scripting.Dictionary")
        For Each c In myRange
            If Rows(c.Row).Hidden = False Then .Item(c.Value) = c.Value
        Next c
        MakeList = Join(.keys, ", ")
    End With
End Function

Answer 2

根据要求，我清理了这个函数。有几个问题。正如我所提到的，仅仅忽略从重复中创建的错误并不是一个好主意。而是首先检查该值是否在字典中。

此外，我添加了一些错误处理，并让函数返回一个字符串值，我相信这是你想要的。

Public Function MakeList(ByVal myRange As Range) As String
On Error GoTo Errhand:

    Dim c       As Range
    Dim MyDict  As Object: Set MyDict = CreateObject("Scripting.Dictionary")

    For Each c In myRange
        If Not Rows(c.Row).Hidden Then
            If Not MyDict.exists(c.Value2) Then MyDict.Add c.Value2, 1
        End If
    Next

    MakeList = Join(MyDict.keys, ", ")

 cleanExit:
    Set MyDict = Nothing
    Set c = Nothing
    Exit Function

Errhand:
    Debug.Print Err.Number, Err.Description
    GoTo cleanExit
End Function