Option Explicit
Dim ieObj As Object
 
Sub CleanUp()
Application.ScreenUpdating = False
Dim i As Long, j As Long, k As Long
With ActiveSheet
  With .UsedRange
    .Cells.Replace What:=Chr(160), Replacement:="", LookAt:=xlPart, SearchOrder:= _
        xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
    .UnMerge
    .VerticalAlignment = xlCenter
    .WrapText = False
    .HorizontalAlignment = xlLeft
    .Font.ColorIndex = xlAutomatic
    .Font.Underline = False
  End With
  While .Shapes.Count > 0
    .Shapes(1).Delete
  Wend
  .Columns(11).Delete
  .Columns(9).Delete
  .Columns(8).Delete
  .Columns(6).Delete
  .Columns(5).Delete
  .Columns(4).Delete
  .Columns(2).Delete
  For i = 1 To .UsedRange.Rows.Count - 1
    If .Cells(i, 5).Value = "MORTGAGE" Then
      .Cells(i, 5).Value = -(.Cells(i + 1, 5).Value)
    End If
    If Trim(.Cells(i, 2).Value) Like "####-#####" Then
      .Cells(i, 2).Value = Trim(.Cells(i, 2).Value)
      For j = i To .UsedRange.Rows.Count
        If Trim(.Cells(j, 1).Value) <> "" Then Exit For
      Next
      .Cells(i, 8).Value = .Cells(j, 1).Value
      .Cells(i, 9).Value = Replace(Replace(.Cells(i, 7).Value, "City of ", ""), "Town of ", "")
      For k = i + 1 To j
        If .Cells(k, 3).Value <> "" Then
          .Cells(i, 3).Value = .Cells(i, 3).Value & " / " & .Cells(k, 3).Value
        End If
      Next
    End If
  Next
  For i = .UsedRange.Rows.Count To 2 Step -1
    If .Cells(i, 2).Value = "" Then .Rows(i).EntireRow.Delete
  Next
  .Columns(7).Delete
  .Columns(1).Delete
  Call ZipUpdate
  .UsedRange.Rows.AutoFit
  .UsedRange.Columns.AutoFit
End With
Application.ScreenUpdating = True
End Sub
 
Sub ZipUpdate()
Application.ScreenUpdating = False
Dim i As Long
Set ieObj = CreateObject("InternetExplorer.Application")
With ActiveSheet
  For i = 2 To .UsedRange.Rows.Count
    .Cells(i, 8).Value = ZipCode(.Cells(i, 6).Value, .Cells(i, 7).Value, "NY")
  Next
End With
ieObj.Quit: Set ieObj = Nothing
Application.ScreenUpdating = True
End Sub
 
Function ZipCode(Addr As String, City As String, State As String) As String
Dim URL As String, AD As String, Ct As String, St As String, Data As String
Dim Zip As String, i As Long, ieDoc As Object
URL = "https://tools.usps.com/go/ZipLookupResultsAction!input.action?resultMode=0&companyName=&" & _
"address1=" & Addr & "&address2=&city=" & City & "&state=" & State & "&urbanCode=&postalCode=&zip="
With ieObj
  .navigate URL
  Do Until (.readyState = 4 And Not .Busy)
    DoEvents
  Loop
  Set ieDoc = .document
  Data = ieDoc.body.innerText
  Data = Right(Data, Len(Data) - 2400)
  If InStr(1, Data, "Here's the full address") = 0 Then
    ZipCode = ""
  Else
    Data = Mid(Data, InStr(1, Data, "Here's the full address") + 94, 100)
    ZipCode = Mid(Data, InStr(1, Data, "-") - 5, 10)
  End If
End With
Set ieDoc = Nothing
End Function