通过参考文件中的唯一文本在VBA中创建动态范围并循环到仪表板中

Question

我这里有代码从参考文件中获取数据并计算所有唯一文本行，并将它们放在参考文件中的自己的列表中。如果“标题”在第4列中，则应该将每个唯一文本放入此图片中显示的列中。但是现在，它只是从参考文件“title1”获取第一个唯一行并将其循环到每个框中。我想要的是其他独特的文本也要循环。所以，它将是“title1”，“title2”，“title3”等等。虽然我无法弄明白。

Sub unique()

    Dim wsRef As Worksheet
    Dim wsDB As Worksheet

    Set wsRef = Worksheets("reference1")
    Set wsDB = Worksheets("Sheet1")

    With wsRef
        .Range("F1:F60").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("I1"), unique:=True

        Dim arrValues As Variant
        arrValues = .Range("I2", .Range("I" & .Rows.Count).End(xlUp))

    End With

    For i = 1 To ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row

        If Cells(i, 4) = "Title" Then

            For j = 1 To (UBound(arrValues)) Step 1

                With wsDB
                .Range(.Cells(i, j * 4 + 2), .Cells(i, j * 4 + 4)).Value = Application.WorksheetFunction.Transpose(arrValues)

                End With

            Next j

        End If

    Next i

End Sub

Answer 1

看起来您正在尝试复制唯一值表单1工作表并将它们复制到多个列中，相隔4列，在另一个工作表上。我通过在字典中添加唯一值作为键来实现这一点。接下来，我循环遍历4 Step 4计数的列，粘贴第二行中的值。

Sub unique2()

    Dim j As Integer
    Dim arrUniqueValues, arrValues, k
    Dim wsRef As Worksheet
    Dim wsDB As Worksheet

    Dim dict As Object

    Set dict = CreateObject("Scripting.Dictionary")
    Set wsRef = Worksheets("reference1")
    Set wsDB = Worksheets("Sheet1")

    With wsRef

        arrValues = .Range("F1", .Range("F" & .Rows.Count).End(xlUp))
        For Each k In arrValues

            If Len(k) And Not dict.Exists(k) Then dict.Add k, ""

        Next

    End With

    With wsDB

        For j = 6 To 24 Step 4

            .Cells(2, j).Resize(dict.Count).Value = WorksheetFunction.Transpose(dict.Keys)

        Next j

    End With

    Set dict = Nothing
End Sub