Question

我试图获得范围内每列的唯一值＆＃34; RD＆＃34;并将它们显示在单列中。我需要创建一个对象（＆＃34; scripting.Dictionary＆＃34;），其数量与Range＆＃34; RD＆＃34;中的列数一样多。我尝试了这段代码，但结果是＆＃34;运行时错误13＆＃34;。

Private Sub CommandButton1_Click()

Range(Me.RefEdit1).Name = "RD"
Range(Me.RefEdit2).Name = "OT"
Dim d As Object, c As Variant, i As Long, s As Long
Dim JK As Long
Dim o As Collection
JK = Range("RD").Columns.Count
Set d = CreateObject("Scripting.Dictionary")

For k = 0 To JK + 1
    d.Item(k) = CreateObject("Scripting.Dictionary").Item(k)
    c = Range("RD").Columns(k + 1)

    If d.Exists(k) Then
        d.Item(k) = d.Item(k) + 1 'increment
    Else
        d.Item(k) = 1 'set as 1st occurence
    End If

    For i = 1 To UBound(c, 1)
        d.Item(k)(c(i, 1)) = 1
    Next i

    Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count) = Application.Transpose(d.Item(k).Keys)
    Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count).Sort Key1:=Range("OT").Cells((k * 5) + 2, 2).Resize(d.Item(k).Count)
Next k

End Sub

Answer 1

我在下面添加了一些代码来帮助遍历列表，查找唯一值，并将它们添加到新列中。在我的示例中，为了提高效率，我将整个功能封装到单个loop中。我还要在Sheet2中以单元格A1开头的新列中添加唯一值。

如果您需要任何其他帮助，请与我们联系。

基于误解的编辑代码：

Private Sub CommandButton1_Click()
    Dim oDict As Object
    Dim rngToScrub As Range
    Dim rngNewColumnToStoreUnique As Range
    Dim oCol As Range
    Dim cel As Range

    Set rngToScrub = Range(Me.RefEdit1.Value)
    Set rngNewColumnToStoreUnique = Sheet2.Range("A1")

    For Each oCol In rngToScrub.Columns
        Set oDict = CreateObject("Scripting.Dictionary")

        For Each cel In oCol.Cells
            If oDict.exists(cel.Value) Then
                'Do Nothing for Now
            Else
                oDict.Add cel.Value, 0
                rngNewColumnToStoreUnique.Value = cel.Value
                Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
            End If
        Next cel

        Set oDict = Nothing
    Next oCol
End Sub

旧代码：误解了要求

Private Sub CommandButton1_Click()
    Dim oDict As Object
    Dim rngToScrub As Range
    Dim rngNewColumnToStoreUnique As Range
    Dim cel As Range

    Set oDict = CreateObject("Scripting.Dictionary")
    Set rngToScrub = Range(Me.RefEdit1.Value)
    Set rngNewColumnToStoreUnique = Sheet2.Range("A1")

    For Each cel In rngToScrub
        If oDict.exists(cel.Value) Then
            'Do Nothing for Now
        Else
            oDict.Add cel.Value, 0
            rngNewColumnToStoreUnique.Value = cel.Value
            Set rngNewColumnToStoreUnique = rngNewColumnToStoreUnique.Offset(1)
        End If
    Next cel
End Sub

循环创建Object excel vba

1 个答案: