0

2 つの列を通過するコードを作成しました。1 つはキーで、もう 1 つは項目です。重複が見つかった場合は、前のアイテムと一緒にアイテムに追加します。アイテムを印刷しようとすると問題が発生します。キーは正常に出力されますが、アイテムは実行時エラー '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 の前にエラーが発生しています

4

1 に答える 1

0

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

サブ終了

于 2013-07-23T17:54:54.320 に答える