Question

我有一个要求，我在excel中有数千条记录，格式如下。请注意，这存在于A列，我想要实现的是按以下格式拆分：名称，街道地址，城市，州，邮编，电话号码，ID。

请注意，每条记录分为两行，由4行组成。此外，记录可以像Banner Inc一样有一个空白行。

粘贴特殊是非常多余的，并将感谢任何帮助。

由于

Adv Sales 
8 Arch Street Ext 
Seaford,   DE   12073 
(302) 600-8000                 ID:12345 


XYZ Incorporated 
168 N du Pont Hwy 
New Castle,   DE   19720 
(302) 300-7000                 ID:89000 


Audi 
200 Sys Rd 
Wilmin,   DE   20001 
(302) 700-4000                 ID:71000 


Baker  
3000 Governor Printz Blvd 
Wilmington,   DE   19802 
(302) 700-3000                 ID:70000 


Banner Inc. 

Delmar,   DE   19000 
(302) 800-0000               ID:7000

更新

以下是代码的输出：

Auto Sales  2024 E Platte Ave   Colorado    Springs,        -719    520-0995
 Auto Sales     1551 S Broadway     Cortez,     CO  -970    564-1490

当像科罗拉多州的城市一样存在空间时，国家就会失踪。
联系号码的前三位数位于不同的栏目中，为负数。
缺少邮政编码和身份证件。

最新更新： 你可以用以下数据集的数组运行你的代码吗？：

1995 A Sales 
2024 E Platt Ave 
Colorado Springs,   CO   80909 
(719) 520-0995                 ID:70686 


4x 4 Sales 
1551 S Broadway 
Cortez,   CO   81321 
(970) 564-1490                 ID:70687 


A & I  Sales 
5030 Yo st 
Denver,   CO   80216 
(303) 756-6814                 ID:70693 


A Courtesy Auto Sales 
6000 E 49th Ave 
Commerce City,   CO   80022 
(303) 288-9472                 ID:70691 


Able Auto Sales LLC 
981 E Highway 224 
Denver,   CO   80229 
(303) 227-0175                 ID:70688

它给了我以下错误：运行时错误'9'：下标超出范围

再次感谢您的帮助。

Answer 1

这是另一个应该很快运行的版本。它需要一个重命名cContact的Class模块和一个常规模块。您可以通过选择模块来重命名类模块; F4显示属性，然后更改（名称）。

您可以在常规模块中看到更改源数据和结果的工作表名称的位置。它假定数据从A1开始，并且在您展示的时候布局很多，尽管有一些灵活性允许zip + 4和没有区号的电话号码。

课程模块

Option Explicit
'Rename this module:  cContact

Private pName As String
Private pStreetAddress As String
Private pCity As String
Private pState As String
Private pZip As Long
Private pPhoneNumber As Variant
Private pID As Long

Public Property Get Name() As String
    Name = pName
End Property
Public Property Let Name(Value As String)
    pName = Value
End Property

Public Property Get StreetAddress() As String
    StreetAddress = pStreetAddress
End Property
Public Property Let StreetAddress(Value As String)
    pStreetAddress = Value
End Property

Public Property Get City() As String
    City = pCity
End Property
Public Property Let City(Value As String)
    pCity = Value
End Property

Public Property Get State() As String
    State = pState
End Property
Public Property Let State(Value As String)
    pState = Value
End Property

Public Property Get Zip() As Long
    Zip = pZip
End Property
Public Property Let Zip(Value As Long)
    pZip = Value
End Property

Public Property Get PhoneNumber() As Variant
    PhoneNumber = pPhoneNumber
End Property
Public Property Let PhoneNumber(Value As Variant)
    pPhoneNumber = Value
End Property

Public Property Get ID() As Long
    ID = pID
End Property
Public Property Let ID(Value As Long)
    pID = Value
End Property

常规模块

Option Explicit
Sub ContactRowsToColumns()
    Dim cC As cContact, colC As Collection
    Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
    Dim vSrc As Variant, vRes() As Variant
    Dim I As Long, J As Long
    Dim S As String, S1 As String

'Alter as needed depending on worksheet names for Source data
'  and results location.

'Source data assumed to start in row 1, Column A
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
    Set rRes = wsRes.Cells(1, 1)

With wsSrc
    vSrc = .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
End With

'Collect the data
Set colC = New Collection
For I = 1 To UBound(vSrc, 1) Step 6
    Set cC = New cContact
    With cC
        .Name = vSrc(I, 1)
        .StreetAddress = vSrc(I + 1, 1)
        S = Trim(Replace(vSrc(I + 2, 1), Chr(160), ""))
        .City = Left(S, InStr(1, S, ",") - 1)
        .State = Left(Trim(Mid(S, InStr(1, S, ",") + 1)), 2)
        .Zip = Val(Replace(Mid(Trim(S), InStrRev(Trim(S), " ") + 1), "-", ""))
            S = Trim(vSrc(I + 3, 1))
            S1 = ""
            For J = 1 To InStr(1, S, "ID") - 1
                If IsNumeric(Mid(S, J, 1)) Then S1 = S1 & Mid(S, J, 1)
            Next J
        .PhoneNumber = CDec(S1)
        .ID = Mid(S, InStr(1, S, "ID") + 3)
        colC.Add cC
    End With
Next I

'Populate results array
ReDim vRes(0 To colC.Count, 1 To 7)
vRes(0, 1) = "Name"
vRes(0, 2) = "Street Address"
vRes(0, 3) = "City"
vRes(0, 4) = "State"
vRes(0, 5) = "Zip"
vRes(0, 6) = "Phone Number"
vRes(0, 7) = "ID"

For I = 1 To colC.Count
With colC(I)
    vRes(I, 1) = .Name
    vRes(I, 2) = .StreetAddress
    vRes(I, 3) = .City
    vRes(I, 4) = .State
    vRes(I, 5) = .Zip
    vRes(I, 6) = .PhoneNumber
    vRes(I, 7) = .ID
End With
Next I

'Write results to worksheet
Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
With rRes
    .EntireColumn.Clear
    .Value = vRes
    With Rows(1)
        .Font.Bold = True
        .HorizontalAlignment = xlCenter
    End With

    .Columns(5).NumberFormat = "[<100000]00000;[>100000]00000-0000"
    .Columns(6).NumberFormat = "[<10000000]000-0000;[>10000000](000) 000-0000"
    .EntireColumn.AutoFit
End With
End Sub

Answer 2

以下是使用数组的版本：

Option Explicit

Public Sub transposeRecord()
    Const UNIT  As Byte = 4
    Const ITMS  As Byte = 6
    Const DELID As String = "ID:"
    Dim ur As Range, lr As Long, lc As Long, i As Long, v As Variant, s As Variant
        Set ur = ActiveSheet.UsedRange
        lr = ur.Cells(ur.Row + ur.Rows.Count, ur.Column).End(xlUp).Row
        lc = ur.Cells(ur.Row, ur.Column + ur.Columns.Count).End(xlToLeft).Column
    v = ur.Range(ur.Cells(ur.Row, ur.Column), ur.Cells(lr, lc + 1 + ITMS))
    For i = 1 To lr
        v(i, ITMS - 4) = Trim(v(i + UNIT - 3, 1))       'Street Address
        If Len(v(i + UNIT - 2, 1)) > 0 Then             'City-State-Zip
            s = Split(v(i + UNIT - 2, 1), "   ")
            v(i, ITMS - 3) = Left(s(0), Len(s(0)) - 1)  'City
            v(i, ITMS - 2) = Trim(s(1))                 'State
            v(i, ITMS - 1) = Trim(s(2))                 'Zip
        End If
        If Len(v(i + UNIT - 1, 1)) > 0 Then             'PhoneNumber-ID
            s = Split(v(i + UNIT - 1, 1), DELID)
            v(i, ITMS + 0) = Trim(s(0))                 'PhoneNumber
            v(i, ITMS + 1) = DELID & Trim(s(1))         'ID
        End If
        i = i + ITMS - 1
    Next
    Application.ScreenUpdating = False
        ur.Range(ur.Cells(ur.Row, ur.Column), ur.Cells(lr, lc + 1 + ITMS)) = v
        ActiveSheet.AutoFilterMode = False
            Set ur = ActiveSheet.UsedRange
            ur.AutoFilter Field:=ITMS + 1, Criteria1:="="
            ur.Offset(1).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            ur.EntireColumn.AutoFit
        ActiveSheet.AutoFilterMode = False
        ur.Cells(1).Select
    Application.ScreenUpdating = True
End Sub

将行转置并拆分为列

2 个答案: