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

Ошибка в линии до конца Sub

Answer 1

Я обнаружил, что при использовании Transpose в ячейке может быть не более 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