Excel - 如何获取地址的各个组成部分答案

【问题标题】：Excel - How to grab individual components of a addressExcel - 如何获取地址的各个组成部分
【发布时间】：2020-07-18 16:02:36
【问题描述】：

我在 Excel 中有一个包含完整地址的大列表。每个地址都有一个单元格。我无法创建一个公式来获取街道名称以放入另一个单元格并获取城市以放入另一个单元格。

以下是我的数据的示例

12 Apple RD Harwich, MA 11111
1213 Strawberry Crossing Loop Tampa, FL 22222
123 Pear Dr. Colorado Springs, CO 33333
12345 RIVERSIDE DR Lowertown, PA 44444
6232 N Rockstar ST Philadelphia, PA 44444
123 TOWN ST Plympton, MA 55555

【问题讨论】：

这能回答你的问题吗？ Separate address elements from 1 cell in Excel
这实际上非常困难，因为 excel 不知道街道名称何时停止以及城市名称何时开始。
您需要构建一个可能的城市名称表，并使用一些逻辑来确保考虑到重叠（例如，一个名称与另一个名称的一部分）。完成此操作后，您可以轻松地将其余部分分开。

标签： excel

【解决方案1】：

我没有找到一种快速简便的方法来解决您的问题，但这里有一种方法可以高效快速地完成所需的工作 - 可能比您花时间获取最多只能生成的代码更有效需要审查的结果。

简而言之，此处提供的代码将在您单击每个单元格时为每个单元格创建一个文本框。它是一个文本框，因为它提供了单元格没有的功能。在文本框中输入一个逗号，将街道地址与城市分开，然后按 Enter。拆分在现场完成，可立即编辑，文本框移至下一行。

代码可以处理更多的逗号。它可以单独处理每个部分。我已经在州和邮政编码部分证明了这一点。代码中有一个注释，您可以在其中删除此额外内容。该代码还将逗号（以及当时所做的任何其他更改）添加到原始数据中。代码中还有一个注释，您可以在其中删除一行以保持原始数据不变。

代码有点复杂，同时也有些粗糙，因为它是从另一个项目改编而来的。因为它现在由 2 个部分组成。第一部分包含调用另一部分中的其他过程的事件过程。后者还包含自身的支持功能。第一部分必须安装在您想要操作的工作表的代码模块中。那是其中包含原始地址的工作表。您可以在同一工作簿中的多个工作表后面安装相同的代码。这是第 1 部分。

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ' 069

    Const StopAction As Boolean = False      ' change to TRUE to stop
    Const SourceClm  As Long = 1            ' column containing the data
    
    If StopAction Or Target.Column <> SourceClm Then
        KillTbx Target
    Else
        SetTbx Target.Cells(1)
    End If
End Sub

Private Sub Splitter_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, _
                           ByVal Shift As Integer)
    ' NIC 047 09 Jun 2020
    KeyCode = KeyUpEvent(KeyCode, Shift)
End Sub

请注意顶部的两个常数。您可以设置它们以满足您的需求。 StopAction，如果 TRUE 将禁用文本框的创建，实际上将您的工作表返回到其原始行为。 SourceClm 指定您拥有原始数据的列。在我的试验中，列 A 由编号 1 标识。如果您在同一个工作簿中有多个安装，这些设置可能会有所不同。

下面的代码进入标准代码模块。那是您必须插入的模块。默认情况下，VBA 将其命名为Module1。我建议适当地重命名它。我将我的命名为 STO_62962096，如果需要，它将帮助我再次找到该线程。

Option Explicit
    
Private Const MagName   As String = "Splitter"

Sub SetTbx(Target As Range)
    ' 069
    
    Dim Tbx         As OLEObject            ' the TextBox being created
    Dim BackColor   As Long                 ' background color
    Dim FontColor   As Long                 ' font color
    
    BackColor = 16777152                    ' = sky blue
    FontColor = vbBlack                     ' = 0
    
    On Error Resume Next
    Set Tbx = ActiveSheet.OLEObjects(MagName)
    If Err Then
        Set Tbx = Target.Worksheet.OLEObjects _
                        .Add(ClassType:="Forms.TextBox.1", _
                             Link:=False, _
                             DisplayAsIcon:=False, _
                             Left:=100, Top:=100, _
                             Width:=100, Height:=20)
    End If
    
    With Tbx
        With .Object
            .BackColor = BackColor
            .SpecialEffect = fmSpecialEffectFlat
            .BorderStyle = fmBorderStyleSingle
            .IntegralHeight = False
            .ForeColor = FontColor
            .Font.Size = Target.Font.Size
            .Text = Target.Value
        End With
        .Left = Target.Left
        .Top = Target.Top
        .Width = Target.Width
        .Height = (Target.Offset(1).Top - .Top)
        .Name = MagName
        .Activate
    End With
End Sub

Sub KillTbx(Target As Range)
    ' 069

    Dim Tbx             As OLEObject        ' TextBox
    
    On Error Resume Next
    Set Tbx = Target.Worksheet.OLEObjects(MagName)
    If Err = 0 Then Tbx.Delete
    Err.Clear
    Target.Select
End Sub

Function KeyUpEvent(ByVal KeyCode As Integer, _
                    ByVal Shift As Integer) As Integer
    ' 069

    Dim Tbx         As OLEObject
    Dim n           As Long                 ' offset
    
    Set Tbx = ActiveSheet.OLEObjects(MagName)
    If KeyCode = 13 Then                    ' Enter
        With Tbx
            SplitAddress .Object.Text, .TopLeftCell.Row
            ' remove the next line to KEEP original data
            .TopLeftCell.Value = .Object.Text
            KeyCode = 40                    ' move to next row
        End With
    End If
    
    Select Case KeyCode
        Case 38, 40                         ' Up-arrow / Down-arrow
            n = IIf(KeyCode = 38, -1, 1)
            Tbx.TopLeftCell.Offset(n).Select
            Tbx.Object.Text = ActiveCell.Value
        Case 9                              ' tab: move right/left
            n = IIf(Shift, -1, 1)
            Tbx.TopLeftCell.Offset(, n).Select
            Tbx.Object.Text = ActiveCell.Value
    End Select
    
    KeyUpEvent = KeyCode
End Function

Private Sub SplitAddress(ByVal Txt As String, _
                         ByVal Rt As Long)
    ' 069
    
    Const TgtClm    As Long = 4             ' first target column (change to suit)
    Const StateClm  As Long = 7             ' State followed by ZIP (change to suit)
    
    Dim Sp()        As String               ' address array
    Dim Ct          As Long                 ' target column
    Dim Arr         As Variant              ' output array
    
    If Len(Txt) Then
        ReDim Arr(1 To StateClm - TgtClm + 2)
        Sp = Split(Txt, ",")
        For Ct = 0 To UBound(Sp)
            Arr(Ct + 1) = Trim(Sp(Ct))
        Next Ct
        
        ' remove the next block of 5 lines to NOT separate state & ZIP
        Sp = Split(Trim(Replace(Sp(Ct - 1), "  ", " ")))
        Arr(Ct) = ""
        For Ct = 0 To UBound(Sp)
            Arr(Ct + StateClm - TgtClm + 1) = Trim(Sp(Ct))
        Next Ct
        
        Cells(Rt, TgtClm).Resize(, UBound(Arr)).Value = Arr
        Columns(TgtClm).Resize(, StateClm - TgtClm + 2).AutoFit
    End If
End Sub

查找过程 SplitAddress 并调整您在其中找到的两个常量。该代码将地址拆分为理论上无限数量的部分。其中第一个将被写入上述代码中名为 TgtClm 的列 4 中，该列标识 D 列。State/ZIP 组合有其自己的相似设计，因此它自己的第一列（第一个在这种情况下为 2）。如果您不使用此功能（您可以在同一过程中禁用它），请将常量 StateClm 设置为至少等于您期望的最大拆分数的数字。

请注意，代码创建了一个包含StateClm - TgtClm + 2 元素的数组。如果您只需要 3 列，根据您的问题，StateClm - TgtClm + 2 必须 => 3。在结果右侧，代码将覆盖此公式指定的尽可能多的列的现有数据。

【讨论】：