VBA Scripting.dictionary run-time error '13' type mismatch

问题

I have written code to go through two columns, one will be the key and the other item/items. It goes through and finds the keys, if it finds a duplicate it adds it to the items along with the previous item. The problem comes when I try to print out the items. The keys print out fine but the items give me the run-time error '13' type mismatch.

Here is the code.

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

Error is on line before End Sub

回答1:

I found that when using Transpose you can only have maximum of 255 characters in the cell. I solved this problem by creating a variable and setting it equal to the items and looping through each and copying to the sheet.

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

来源：https://stackoverflow.com/questions/17549379/vba-scripting-dictionary-run-time-error-13-type-mismatch

标签

vba

scripting.dictionary