Need help with finding duplicate addresses through an entire workbook and then return valu

So if you type an address on any Sheet that has already been entered it goes to the first entry and changes the date to the current date deleting the newest entry?

try

Sub ertert()
Dim x, y(), i&, j&, k&, s$, wsh As Worksheet, ky, sp
k = 1
With CreateObject("Scripting.Dictionary")
    .CompareMode = 1
    For Each wsh In ThisWorkbook.Worksheets
        If Not wsh Is ActiveSheet Then
            x = wsh.Range("G2:K" & wsh.Cells(Rows.Count, 7).End(xlUp).Row + 1).Value
            For i = 1 To UBound(x)
                If Len(x(i, 1)) Then
                    If Not .Exists(x(i, 1)) Then
                        .Item(x(i, 1)) = x(i, 5)
                    Else
                        s = .Item(x(i, 1))
                        If InStr(s, "~") = 0 Then
                            If Not .Exists(s) Then k = k + 1: .Item(s) = k
                        End If
                        If Not .Exists(CStr(x(i, 5))) Then k = k + 1: .Item(CStr(x(i, 5))) = k
                        .Item(x(i, 1)) = s & "~" & x(i, 5)
                    End If
                End If
            Next i
        End If
    Next wsh
    ReDim y(1 To .Count, 1 To k): y(1, 1) = "DUPLICATE ADDRESS": j = 1
    For i = 2 To k: y(1, i) = "Date " & i - 1: Next i
    For Each ky In .keys
        If InStr(.Item(ky), "~") Then
            j = j + 1: sp = Split(.Item(ky), "~"): y(j, 1) = ky
            For i = 0 To UBound(sp)
                y(j, .Item(sp(i))) = sp(i)
            Next i
        End If
    Next ky
End With
With Range("A1")
    .CurrentRegion.ClearContents: .Resize(j, k).Value = y
End With
End Sub

edited
I wanted to experiment with If Len(.Item(s)) , but nothing happened.
I changed the code and replaced the file