Question

我有一长串联系人详细信息，这些详细信息按照 2列组织成阻止，如下所示：

A       B
Name    John
Country USA
Phone   1234
Email   j@hotmail.com

Name    John
Country USA
Phone   1234

Name    John
Country USA

我想这样组织它们：

Name Country Phone Email
John USA     1234  j@hotmail.com
John USA     1234  
John USA

如果块的长度都相同（即所有的行都有4行），那么使用过滤器按col1名称选择并复制到新列很容易，但是你会注意到有时会丢失电子邮件，电话等等所以每个联系人的总块长度不同，因此在过滤到新列后它们不会对齐。

一种方法是使用“名称”转换每个块作为每个块应该转换的起点和终点但是我不确定如何。也许有一种更简单的方法？

我怎么能最好地接近这个？

Answer 1

Option Explicit

Sub transpose()

    'This code assumes "Name", "Country", "Email" and "Phone" are spelled the same for each 'block', case not important

    Dim wks As Worksheet
    Dim i As Integer
    Dim lastRow As Integer
    Dim outRowCounter As Integer
    Dim heading As String

    Set wks = Worksheets("Sheet1")

    lastRow = wks.Range("A65536").End(xlUp).Row
    outRowCounter = 1

    'assumes the output colums are Name = 5, Country = 6, Phone = 7, Email = 8
    For i = 1 To lastRow

        If LCase(wks.Cells(i, 1).Value) = "name" Then
            outRowCounter = outRowCounter + 1
            wks.Cells(outRowCounter, 5).Value = wks.Cells(i, 2).Value
        ElseIf wks.Cells(i, 1).Value <> "" Then
            heading = wks.Cells(i, 1).Value
            Select Case LCase(heading)
                Case "country"
                    wks.Cells(outRowCounter, 6).Value = wks.Cells(i, 2).Value
                Case "phone"
                    wks.Cells(outRowCounter, 7).Value = wks.Cells(i, 2).Value
                Case "email"
                    wks.Cells(outRowCounter, 8).Value = wks.Cells(i, 2).Value
            End Select
        End If
    Next i

    'clean up
    Set wks = Nothing
End Sub

Answer 2

我建议定义一个类，其属性是您尝试的不同变量＆＃34; map＆＃34 ;:姓名，国家，电话，电子邮件。然后遍历列表并将每个Class添加到集合中;然后将集合输出到某个范围。

这样做有一些优点，不仅可以使代码更易于阅读和调试，而且还可以在必要时添加其他属性。

请注意，数据首先被读入VBA数组;处理;结果放入另一个VBA数组，然后写入工作表。此方法通常比重复访问每个单元格数据的工作表快5-10倍。

代码中的假设是每个＆＃34;块＆＃34;以＆＃34;名称＆＃34;开头在A栏中。

首先插入此类模块并将其重命名为cPeople

Option Explicit
Private pName As String
Private pCountry As String
Private pPhone As String
Private pEmail As String

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

Public Property Get Country() As String
    Country = pCountry
End Property
Public Property Let Country(Value As String)
    pCountry = Value
End Property

Public Property Get Phone() As String
    Phone = pPhone
End Property
Public Property Let Phone(Value As String)
    pPhone = Value
End Property

Public Property Get Email() As String
    Email = pEmail
End Property
Public Property Let Email(Value As String)
    pEmail = Value
End Property

然后，插入此常规模块：

Option Explicit
Sub ReOrderList()
    Dim wsRaw As Worksheet, vRaw As Variant
    Dim wsRes As Worksheet, rRes As Range, vRes() As Variant
    Dim cP As cPeople, colP As Collection
    Dim I As Long

'Results go here
Set wsRes = Worksheets("Sheet2")
Set rRes = wsRes.Range("E1")

'Get Raw Data
Set wsRaw = Worksheets("sheet2")
With wsRaw
    vRaw = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(columnsize:=2)
End With

'collect the People objects
Set colP = New Collection
For I = 1 To UBound(vRaw)
    If vRaw(I, 1) = "Name" Then
        Set cP = New cPeople
        With cP
            .Name = vRaw(I, 2)
            Do Until I = UBound(vRaw, 1)
                I = I + 1
                Select Case vRaw(I, 1)
                    Case "Name"
                        colP.Add cP
                        I = I - 1
                        Exit Do
                    Case "Country"
                        .Country = vRaw(I, 2)
                    Case "Phone"
                        .Phone = vRaw(I, 2)
                    Case "Email"
                        .Email = vRaw(I, 2)
                End Select
            Loop
        End With
    End If
Next I
colP.Add cP

'Set up results array
ReDim vRes(0 To colP.Count, 1 To 4)

'Column Headers
vRes(0, 1) = "Name"
vRes(0, 2) = "Country"
vRes(0, 3) = "Phone"
vRes(0, 4) = "Email"

For I = 1 To UBound(vRes, 1)
    With colP(I)
        vRes(I, 1) = .Name
        vRes(I, 2) = .Country
        vRes(I, 3) = .Phone
        vRes(I, 4) = .Email
    End With
Next I

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
Application.ScreenUpdating = False
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With
Application.ScreenUpdating = True

End Sub

根据实际项目的需要，更改原始数据的工作表名称，结果以及结果范围（左上角单元格）。我碰巧使用Sheet2与A：B列中的原始数据，结果在E：H中。享受。

在Excel中单列成多个？

2 个答案: