kodu düzenledim dener misiniz?
sadece kırmızı denetleme kodu eklendi
If dgr <> "" And Trim(Cells(x, 3)) <> "" Then If Dict.Exists(dgr) = True Then Dict(dgr) = Dict(dgr) & "," & Cells(x, 3) Else Dict.Add dgr, Cells(x, 3)

Sub EksikBul()

SonStr = Cells(Rows.Count, "AF").End(xlUp).Row

If SonStr < 2 Then SonStr = 2



Range("AF2:AF" & SonStr).ClearContents



Dim Dict As Object

Set Dict = CreateObject("Scripting.Dictionary")

    Dict.CompareMode = vbTextCompare

SonStr = Cells(Rows.Count, "B").End(xlUp).Row

For x = 3 To SonStr

dgr = Trim(Cells(x, 2))

    If dgr <> "" And Trim(Cells(x, 3)) <> "" Then If Dict.Exists(dgr) = True Then Dict(dgr) = Dict(dgr) & "," & Cells(x, 3) Else Dict.Add dgr, Cells(x, 3)

Next x



Dim key As Variant

i = 0

If Dict.Count < 1 Then Exit Sub

For Each key In Dict.Keys

Dim SyfAktr() As Variant

xDz = Evaluate("{" & Dict(key) & "}")

xMin = WorksheetFunction.Min(xDz)

xMax = WorksheetFunction.Max(xDz)

xdKey = "," & Dict(key) & ","

    For xXL = xMin + 1 To xMax - 1

    VarMi = InStr(1, xdKey, "," & xXL & ",")

        If VarMi = 0 Then

        ReDim Preserve SyfAktr(i)

                SyfAktr(UBound(SyfAktr)) = key & " " & xXL

        i = i + 1

        End If

    Next xXL

Next key



j = 0 'transpose

    ReDim SonDizi(LBound(SyfAktr) To UBound(SyfAktr), 0)

        For j = LBound(SyfAktr) To UBound(SyfAktr)

            SonDizi(j, 0) = SyfAktr(j)

        Next j



Range("AF2").Resize(UBound(SyfAktr) + 1).Value = SonDizi ' Application.Transpose(SyfAktr)

End Sub