Петля для создания объекта excel vba

Question

Я попытался получить уникальное значение каждого столбца в диапазоне «RD» и отобразить их в одном столбце. Мне нужно создать объект («scripting.Dictionary»), где столько же столбцов в «RD». Я пробовал этот код, но в результате «Ошибка времени выполнения 13».

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