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 

오류가 내가 사용하는 경우에만 셀에 최대 255 자를 가질 수 트랜스 것을 발견

Answer 1

하위 종료하기 전에 라인에 있습니다. 변수를 만들고 항목과 동일하게 설정하고 각각을 반복하고 시트에 복사하여이 문제를 해결했습니다. `응용 프로그램 무엇

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 

최종 하위