Compare 2 sheets and result in sheet 3

Sub TEST()
Dim a, dic As Object, i&, j&, t$, z()
Set dic = CreateObject("scripting.dictionary")
a = Sheet1.[B3].CurrentRegion.Value
ReDim z(1 To UBound(a), 1 To UBound(a, 2))
For i = 1 To UBound(a)
t = CStr(a(i, 2))
If Not dic.exists(t) Then dic(t) = Application.Index(a, i)
Next i
a = Sheet2.[c3].CurrentRegion.Value
For i = 1 To UBound(a)
t = CStr(a(i, 1))
If dic.exists(t) Then
j = j + 1
For ii = 1 To UBound(dic(t))
z(j, ii) = dic(t)(ii)
Next ii
Else
j = j + 1
z(j, 2) = a(i, 1)
End If
Next i
With Sheets.Add
.Name = "Sheet3"
.[B3].Resize(UBound(z), UBound(z, 2)) = z
End With
End Sub

Sub TEST()
Dim a, dic As Object, i&,ii&, j&, t$, z()
Set dic = CreateObject("scripting.dictionary")
a = Sheet1.[B3].CurrentRegion.Value
[B][COLOR=#FF0000]ReDim z(1 To UBound(a) + WorksheetFunction.CountA(Sheet2.Columns(3)), 1 To UBound(a, 2))[/COLOR][/B]
 For i = 1 To UBound(a)
   t = CStr(a(i, 2))
   If Not dic.exists(t) Then dic(t) = Application.Index(a, i)
 Next i
 a = Sheet2.[c3].CurrentRegion.Value
 
 For i = 1 To UBound(a)
    t = CStr(a(i, 1))
    If dic.exists(t) Then
       j = j + 1
       For ii = 1 To UBound(dic(t))
        z(j, ii) = dic(t)(ii)
       Next ii
    Else
        j = j + 1
        z(j, 2) = a(i, 1)
    End If
 Next i
 With Sheets.Add
    .Name = "Sheet3"
    .[B3].Resize(UBound(z), UBound(z, 2)) = z
 End With
End Sub