VBA цикл запроса scripting.dictionary

Question

Я получил это:

Set dict = CreateObject("Scripting.Dictionary") 

    rn = 2 
    Do While ThisWorkbook.Sheets("1").Range("B" & rn).Value <> "" 
     If (ThisWorkbook.Sheets("1").Range("B" & rn).Value <> "") Then dict("&&1") = dict & ThisWorkbook.Sheets("1").Range("B" & rn).Value & ", " 
     rn = rn + 1 
    Loop 

Но это не работает, я получаю ошибку 450 в VBA.

Что нужно сделать, так это следующее: каждое значение в столбце B (если оно не пустое) должно быть добавлено в dict, разделенное запятой. Если после последней строки он не может установить запятую.

Я думаю, что я на правильном пути, но там что-то не хватает.

Answer 1

Чтобы получить все уникальные значения в строку можно изменить код следующим образом

Обратите внимание, что вы должны использовать ThisWorkbook.Sheets(1) не ThisWorkbook.Sheets("1")

Pls использовать MsgBox Left$(strOut, Len(strOut) - 2) зафиксировать заднюю нетребуемые часть

Sub a() 
Dim ws As Worksheet 
Set dict = CreateObject("Scripting.Dictionary") 
Dim strOut As String 

Set ws = Sheets(1) 

    rn = 2 
    Do While ws.Range("B" & rn).Value <> "" 
     If Len(ws.Range("B" & rn).Value) > 0 Then 
      If dict.exists(ws.Range("B" & rn).Value) Then 
       Else 
       dict.Add ws.Range("B" & rn).Value, 1 
      strOut = strOut & (ws.Range("B" & rn).Value & ", ") 
      End If 
     End If 
     rn = rn + 1 
    Loop 
    MsgBox strOut 
End Sub 

Answer 2

просто бросить в более сжатой версии brettdj решения

Sub main() 
    Dim cell As Range 
    Dim strOut As String 

    With CreateObject("Scripting.Dictionary") 
     For Each cell In Sheets(1).Range("B2", Sheets(1).Cells(.Rows.Count, "B")).SpecialCells(xlCellTypeConstants, xlTextValues) 
      .Item(cell.Value) = 1 
     Next 
     strOut = Join(.keys, ",") 
     MsgBox strOut 
    End With 
End Sub