使用各種分隔符將地址拆分為街道地址、城市、州、郵編和國家

Question

我的數據在 Excel 中。 我有幾張數據，其中地址總是在每張紙的同一列中。 地址格式的示例包括：

1155 15th Street NW Suite 600 Washington, DC 20005 US
4600 Emperor Blvd #200 Durham, NC 27703-8577 美國
200 Stevens Drive 費城, PA 19113 美國
505 City Parkway West Orange, CA 92868 US
550 S Caldwell St, Charlotte, NC 28202-2633 US
1643 NW 136th Ave Ste H200 Sunrise, FL 33323-2857 美國

我已經嘗試了下面的代碼，但在代碼“sCity = Trim(Mid$(rCell.Value, Len(sAddress) + 1, lStatePos - Len(sAddress) - 1))”中出現錯誤

誰能幫我弄清楚如何解決這個問題？

Sub SplitAddresses()

    Dim vaStates As Variant
    Dim vaStreets As Variant
    Dim i As Long
    Dim rCell As Range
    Dim sAddress As String
    Dim sCity As String, sState As String
    Dim sZip As String
    Dim lStreetPos As Long, lStatePos As Long

    vaStates = Array(“ AL “, “ AK “, “ AZ “, “ AR “, “ CA “, “ CO “, “ CT “, “ DE “, “ DC “, “ FL “, “ GA “, “ HI “, “ ID “, “ IL “, “ IN “, “ IA “, “ KS “, “ KY “, “ LA “, “ ME “, “ MD “, “ MA “, “ MI “, “ MN “, “ MS “, “ MO “, “ MT “, “ NE “, “ NV “, “ NH “, “ NJ “, “ NM “, “ NY “, “ NC “, “ ND “, “ OH “, “ OK “, “ OR “, “ PA “, “ RI “, “ SC “, “ SD “, “ TN “, “ TX “, “ UT “, “ VT “, “ VA “, “ WA “, “ WV “, “ WI “, “ WY “, “ GU “, “ PR “)
    vaStreets = Array(" CR ", " BLVD ", " RD ", " ST ", " AVE ", " CT ")

    For Each rCell In Sheet1.Range("A1:A5").Cells
        sAddress = "": sCity = "": sZip = "": sState = ""
        For i = LBound(vaStreets) To UBound(vaStreets)
            lStreetPos = InStr(1, rCell.Value, vaStreets(i))
            If lStreetPos > 0 Then
                sAddress = Trim(Left$(rCell.Value, lStreetPos + Len(vaStreets(i)) - 1))
                Exit For
            End If
        Next i

        For i = LBound(vaStates) To UBound(vaStates)
            lStatePos = InStr(1, rCell.Value, vaStates(i))
            If lStatePos > 0 Then
                sCity = Trim(Mid$(rCell.Value, Len(sAddress) + 1, lStatePos - Len(sAddress) - 1))
                sState = Trim(Mid$(rCell.Value, lStatePos + 1, Len(vaStates(i)) - 1))
                sZip = Trim(Mid$(rCell.Value, lStatePos + Len(vaStates(i)), Len(rCell.Value)))
                Exit For
            End If
        Next i

        rCell.Offset(0, 1).Value = "'" & sAddress
        rCell.Offset(0, 2).Value = "'" & sCity
        rCell.Offset(0, 3).Value = "'" & sState
        rCell.Offset(0, 4).Value = "'" & sZip

    Next rCell

End Sub

這是我得到的錯誤： error_image

Answer 1

您的拆分邏輯中存在一些不一致的地方，這還不包括您還必須將大寫街道數組與Ucase()字符串值進行比較。

然而，好消息是 - 由於您似乎應用了后續地址邏輯，即分組城市、州 + 壓縮最后一個冒號分隔符，您可以嘗試以下代碼：

Option Explicit             ' declaration head of code module
Enum c                      ' define column constants
    [_Start] = 0
    add1
    City
    State
    Zip
End Enum

Sub SplitAddresses()
With Sheet1
    'define dataset
    Dim lastRow As Long: lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
    Dim rng As Range: Set rng = .Range("A2:A" & lastRow)
    'assign to variant datafield array (provide for 4 columns: Add+City+State+ZIP)
    Dim v: v = rng.Resize(columnsize:=4).Value2
    'split data
    doSplit v
    'write split results to any target, e.g. B:B
    .Range("B2").Resize(UBound(v), 4) = v
End With
End Sub

幫助程序doSplit

Sub doSplit(data)
Dim i As Long
For i = LBound(data) To UBound(data)
    Dim curAddress As String: curAddress = data(i, c.add1)
    
    Dim tokens, tmp
    tokens = Split(curAddress, ",")
    
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'a) analyze string part after last ","
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    tmp = Split(Trim(tokens(UBound(tokens))) & " ", " ", 2)
    'aa) add State + Zip (to columns 3..4)
    data(i, c.State) = tmp(0): data(i, c.Zip) = tmp(1)
    
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    'b) analyze first string part
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    tmp = Split(tokens(UBound(tokens) - 1), " ")
    'data(i, c.City) = tmp(UBound(tmp))   '<< only for 1-word city names
     data(i, c.City) = getCity(tmp)       '<< see edit below
    'bb) add City + Address
    data(i, c.add1) = Split(curAddress, data(i, c.City), 2)(0)
    data(i, c.add1) = Replace(data(i, c.add1), ",", "")
Next i
End Sub

幫助功能// 由於@RonRosenfeld 的評論而進行編輯

由於會有由復合詞組成的城市名稱，因此上述 sub 中的城市字符串分配必須從data(r, c.City) = tmp(UBound(tmp))更改為

    data(r, c.City) = getCity(tmp)  ' << function call

函數getCity()

包括檢查common第一部分為“北”、“西”或“新”，以避免至少檢查包含復合城市名稱的詳盡列表。 所有其他需要的多於一個詞的城市名稱必須在額外的列表cities定義：

Function getCity(tmp) As String
'Purp.: return valid city names of either one or two parts
'[1]Definitions
    'a) List common first parts of city names like "West" in "West Orange"
        Dim common$: common = "North,West,South,East,Grand,New"
    'b) List all other needed cities consisting of compound words
        Dim cities$: cities = "Sterling Heights,Ann Arbor"
'[2]Get potential city name
    'a) Define tmp indices of potential city tokens
        Dim first&: first = UBound(tmp) - 1
        Dim secnd&: secnd = UBound(tmp)
    'b) Build city name as compound string of tmp tokens
        Dim City As String
        City = Trim(IIf(first < 0, "", tmp(first) & " ") & tmp(secnd))
'[3]Check common first parts plus additional cities list
    'a) Check for common name parts like e.g. "West" in "West Orange"
        If InStr(common & ",", tmp(first) & ",") Then getCity = City: Exit Function
    'b) Check rest in listed cities and return function result
        getCity = IIf(InStr(cities, City) > 0, City, tmp(secnd))
End Function

Answer 2

根據您的評論，有一個返回字符來描述城市的街道地址，以及地址的常規格式： street|City, State Zip Country算法變得更加簡單，因為一系列Split函數可以將地址部分分開。

我還使用了Type語句——不是必需的，但使代碼更清晰，IMO。 根據格式的不同，某些Trim語句可能不是必需的，但它們不會受到影響。

請注意，您可以更改數據源和結果位置的范圍/工作表以滿足您的特定要求。

編輯：我剛剛讀到您的評論，在從街道地址返回城市之前可能會有多次returns 。

.street代碼.street更改

Option Explicit
Type Address
    street As String
    city As String
    state As String
    zip As String
    country As String
End Type
Sub splitAddresses()
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes As Variant
    Dim myAdr As Address
    Dim v, w, x, y
    Dim I As Long
    
Set wsSrc = Worksheets("sheet1")

'read into vba array for faster processing
With wsSrc
    vSrc = .Range(.Cells(2, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

Set wsRes = Worksheets("Sheet1")
    Set rRes = wsRes.Cells(1, 3)


ReDim vRes(0 To UBound(vSrc), 1 To 5)

'Headers
    vRes(0, 1) = "Street"
    vRes(0, 2) = "City"
    vRes(0, 3) = "State"
    vRes(0, 4) = "Zip"
    vRes(0, 5) = "Country"
    
For I = 1 To UBound(vSrc)
    v = Split(vSrc(I, 1), vbLf)
    With myAdr
        y = v
        ReDim Preserve y(UBound(y) - 1)
        .street = WorksheetFunction.Trim(Join(y, " "))

    w = Split(Trim(v(UBound(v))), ",")
        .city = w(0)
    
    x = Split(Trim(w(1)))
        .state = Trim(x(0))
        .zip = Trim(x(1))
        .country = Trim(x(2))
    
    vRes(I, 1) = .street
    vRes(I, 2) = .city
    vRes(I, 3) = .state
    vRes(I, 4) = .zip
    vRes(I, 5) = .country
End With

Set rRes = rRes.Resize(rowsize:=UBound(vRes, 1) + 1, columnsize:=UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .Rows(1).Font.Bold = True
    .Columns(4).NumberFormat = "@"
    .EntireColumn.AutoFit
End With
    
Next I

End Sub