Question

TL; DR：我需要一个公式来连接可见的单元格，删除重复项，并添加一个＆＃34;，＆＃34;介于值之间。

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

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

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

例如，如果数据是100,100,101,102,101，它将返回＆＃34; 100,101,102。＆＃34;

我的困难在于，当父宏通过自动过滤器并将+第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

根据要求，我清理了这个功能。有一些问题。正如我所提到的那样，忽略从副本创建的错误并不是一个好主意。而是先检查值是否在字典中。

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

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

Answer 2

我实际上并没有理解你的意思

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

用于连接可见单元格的公式，删除重复项

2 个答案: