VBA Scripting.dictionary ошибка времени выполнения «13» несоответствие типа

Question

Я написал код, чтобы пройти через два столбца, один будет ключевым и другим элементом/элементами. Он проходит и находит ключи, если он находит дубликат, он добавляет его к элементам вместе с предыдущим элементом. Проблема возникает, когда я пытаюсь распечатать элементы. Ключи распечатываются отлично, но элементы дают мне несоответствие типа ошибки «13».

Вот код.

Sub All() 
Worksheets("All").Activate 
Dim Server As Variant 
Dim Application As Variant 
Dim colLength As Variant 
Dim dict As Object 
Dim element As Variant 
Dim counter As Integer 
Dim env As Variant 
Dim envLength 
Dim com As Variant 
Dim comLength 
Dim kw As Variant 
Dim kwLength 

'copies pair of columns 
env = Range("A3:B" & WorksheetFunction.CountA(Columns(1)) + 1).Value 
com = Range("D3:E" & WorksheetFunction.CountA(Columns(4)) + 1).Value 
kw = Range("G3:H" & WorksheetFunction.CountA(Columns(7)) + 1).Value 
'sets the start or end point of the pasted pair of columns 
envLength = WorksheetFunction.CountA(Columns(1)) + 1 
comLength = envLength + WorksheetFunction.CountA(Columns(4)) + 1 
kwLength = comLength + WorksheetFunction.CountA(Columns(7)) + 1 
'pastes the copies in two big columns 
ActiveSheet.Range("I3:J" & envLength) = env 
ActiveSheet.Range("I" & (envLength) & ":J" & comLength - 3) = com 
ActiveSheet.Range("I" & (comLength - 3) & ":J" & kwLength - 6) = kw 

Set dict = Nothing 
Set dict = CreateObject("scripting.dictionary") 
colLength = WorksheetFunction.CountA(Columns(9)) + 2 
counter = 1 
Application = Range("I3:I" & colLength).Value 
Server = Range("J3:J" & colLength) 
'Generate unique list and count 
For Each element In Server 
    If dict.Exists(element) Then 
     dict.Item(element) = dict.Item(element) & ", " & Application(counter, 1) 
    Else 
     dict.Add element, Application(counter, 1) 
    End If 
    counter = counter + 1 
Next 
Worksheets("All2").Activate 
ActiveSheet.Range("B2:B" & dict.Count + 1).Value = WorksheetFunction.Transpose(dict.keys) 
ActiveSheet.Range("A2:A" & dict.Count + 1).Value = WorksheetFunction.Transpose(dict.items) 
End Sub 

Ошибка на строке перед End Sub

Answer 1

Я обнаружил, что при использовании Транспонирования вы можете иметь только максимум 255 символов в ячейке. Я решил эту проблему, создав переменную и установив ее равным элементам и прокручивая их каждый и копируя на лист.

Sub Unique() 
Worksheets("All").Activate 
Dim Server As Variant 
Dim App As Variant 
Dim colLength As Variant 
Dim dict As Object 
Dim element As Variant 
Dim counter As Integer 
Dim env As Variant 
Dim envLength 
Dim com As Variant 
Dim comLength 
Dim kw As Variant 
Dim kwLength 
Dim dictItems As Variant 

'copies pair of columns 
env = Range("A3:B" & WorksheetFunction.CountA(Columns(1)) + 1).Value 
com = Range("D3:E" & WorksheetFunction.CountA(Columns(4)) + 1).Value 
kw = Range("G3:H" & WorksheetFunction.CountA(Columns(7)) + 1).Value 
'sets the start or end point of the pasted pair of columns 
envLength = WorksheetFunction.CountA(Columns(1)) + 1 
comLength = envLength + WorksheetFunction.CountA(Columns(4)) + 1 
kwLength = comLength + WorksheetFunction.CountA(Columns(7)) + 1 
'pastes the copies in two big columns 
ActiveSheet.Range("I3:J" & envLength) = env 
ActiveSheet.Range("I" & (envLength) & ":J" & comLength - 3) = com 
ActiveSheet.Range("I" & (comLength - 3) & ":J" & kwLength - 6) = kw 

Set dict = Nothing 
Set dict = CreateObject("scripting.dictionary") 
colLength = WorksheetFunction.CountA(Columns(9)) + 2 
counter = 1 
App = Range("I3:I" & colLength).Value 
Server = Range("J3:J" & colLength).Value 


'Generate unique list of apps and servers 
For Each element In Server 
    If dict.Exists(element) Then 
     If InStr(LCase(dict.item(element)), LCase(App(counter, 1))) = 0 Then 
      dict.item(element) = dict.item(element) & vbLf & App(counter, 1) 
     End If 
    Else 
     dict.Add element, App(counter, 1) 
    End If 
    counter = counter + 1 
Next 

Worksheets("All_Compare").Activate 
ActiveSheet.Range("B2:B" & dict.Count + 1) = WorksheetFunction.Transpose(dict.keys) 
dictItems = dict.items 
For i = 0 To dict.Count - 1 
    Cells(i + 2, 1) = dictItems(i) 
Next 

End Sub