脚本不会在第二张纸上生成输出

我目前正在处理一个脚本，需要在同一个工作簿中的新工作表上生成一个输出（不是下面的代码直接引用的工作表），但是目前我遇到了一个问题，不被复制到另一个。 它运行，但什么都不做。 我该如何解决这个问题？

Sub Collapse() Dim uRng As Range, cel As Range Dim comps As Variant, comp As Variant, r As Variant, v As Variant 'Dim d As Dictionary '~~> Early bind, for Late bind use commented line Dim d As Object Dim a As String Dim Emails As Worksheet Set Emails = Sheets("Emails") With Emails '~~> Sheet that contains your data Set uRng = .Range("F1", .Range("F" & .Rows.Count).End(xlUp)) End With Set d = CreateObject("Scripting.Dictionary") With d For Each cel In uRng a = Replace(cel.Offset(0, -3), "{", "}") comps = Split(a, "}") Debug.Print UBound(comps) For Each comp In comps If InStr(comp, "Computer") <> 0 _ And Len(Trim(comp)) <= 10 Then '~~> I assumed max Comp# is 99 If Not .Exists(cel) Then .Add cel, comp Else If IsArray(.Item(cel)) Then r = .Item(cel) ReDim Preserve r(UBound(r) + 1) r(UBound(r)) = comp .Item(cel) = r Else r = Array(.Item(cel), comp) .Item(cel) = r End If End If End If Next Next End With For Each v In d.Keys With Sheet2 '~~> sheet you want to write your data to If IsArray(d.Item(v)) Then .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) _ .Resize(UBound(d.Item(v)) + 1) = v .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) _ .Resize(UBound(d.Item(v)) + 1) = Application.Transpose(d.Item(v)) Else .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0) = v .Range("B" & .Rows.Count).End(xlUp).Offset(1, 0) = d.Item(v) End If End With Next Set d = Nothing End Sub