Sub cities()
Dim WB_Path As String, WB2 As Workbook, WB2_DATA As Variant, States_Dictionary As Object, _
C_Dict As Object, X As Long, WB1_DATA As Variant, Keys As Variant, P_S() As String, Y As Long, RR As Range
Set States_Dictionary = CreateObject("Scripting.Dictionary")
Const URL As String = "https://simplemaps.com/static/data/us-cities/uscitiesv1.5.csv"
WB_Path = Environ("TEMP") & "\US_Cities.csv"
Call Get_File(URL, WB_Path)
Set WB2 = Workbooks.Open(WB_Path)
With WB2.Worksheets(1).UsedRange
WB2_DATA = .Range(.Cells(2, 1), .Cells(.Rows.Count, 3)).Value2
End With
With States_Dictionary
For X = 1 To UBound(WB2_DATA, 1) 'Create dictionary of cities within states
If Not .Exists(WB2_DATA(X, 3)) Then
Set C_Dict = CreateObject("Scripting.Dictionary")
.Add WB2_DATA(X, 3), C_Dict
'state abbreviation used as key
End If
.Item(WB2_DATA(X, 3)).Add WB2_DATA(X, 1), ""
'city name used as key
Next X
Set RR = ThisWorkbook.Worksheets(1).UsedRange
WB1_DATA = RR.Columns(1).Value2 'assumes address data is in first worksheet in column A
ReDim Preserve WB1_DATA(1 To UBound(WB1_DATA, 1), 1 To 2)
For X = 1 To UBound(WB1_DATA, 1)
P_S = Split(WB1_DATA(X, 1), ",") 'string array containing address data
'stuff after comma (Find state abbreviation and use as key for States_Dictionary)---> returns dictionary
P_S(1) = Trim(P_S(1))
On Error GoTo ABR_Not_Found
TS = .Item(Split(P_S(1), " ")(0)).Keys 'cities were used as keys for specified dictionary
For Y = LBound(TS) To UBound(TS)
'stuff before comma
If InStrRev(P_S(0), TS(Y)) > 0 And InStrRev(P_S(0), TS(Y)) = Len(P_S(0)) - Len(TS(Y)) + 1 Then
WB1_DATA(X, 2) = TS(Y)
Exit For
End If
Next Y
skip:
Next X
End With
RR.Columns(2).Value2 = WorksheetFunction.Index(WB1_DATA, 0, 2)
'Uncomment the line below if you want to close the US cities workbook
'WB2.CLOSE
Exit Sub
ABR_Not_Found:
MsgBox "Abreviation " & Split(P_S(1), " ")(0) & " was not found within queried excel file. Please check " & _
WB2.Name & " for a list of accepted state abbreviations."
err.clear
GoTo skip
End Sub
Public Function Get_File(File As String, SaveFilePathAndName As String)
Dim oStrm As Object, WinHttpReq As Object, Extension As String, File_Name As String
Set WinHttpReq = CreateObject("Msxml2.ServerXMLHTTP")
WinHttpReq.Open "GET", File, False
WinHttpReq.send
File = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
Set oStrm = CreateObject("ADODB.Stream")
With oStrm
.Open
.Type = 1
.Write WinHttpReq.responseBody
.SaveToFile SaveFilePathAndName, 2 ' 1 = no overwrite, 2 = overwrite
.Close
End With
End If
End Function
