这里是一个应该非常快速运行的另一个版本。它需要一个你重命名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
已更新。感谢您指出。 – ddesai
已经回答了很多次了。在一个副本上，尝试复制ColumnA三次，并从每个后续副本的顶部删除一个更多的单元格（向上移动单元格）。然后系列用1-6填充另一列，对其进行过滤并删除除“1”之外的所有行。 – pnuts
@pnuts它只是一个换位的问题，但是索姆细胞需要被拆分（即城市，州和拉链在同一个细胞中）。不过，我认为Dev需要首先向我们展示他的努力。 –