在Excel中将单列变为多个？
我有一个很长的联系人详细列表，这些联系人详细信息被组织成两列，如下所示：
AB 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行），使用filter来selectcol1名称并复制到新的列将会很容易，但是您会注意到有时会丢失电子邮件，电话等，因此总块长度对于每个联系人是不一样的，所以他们将不会alignment后，过滤到新的列。
一种方法是转置每个块使用“名称”作为每个块应该转置的开始和结束点，但我不知道如何。 也许有一个更简单的方法？
我怎么能最好的方法呢？
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
我会build议定义一个类，其属性是你试图“映射”的不同variables：例如名称，国家，电话，电子邮件。 然后你遍历列表并添加每个类到一个集合; 然后将集合输出到某个范围。
这样做有一些优点，不仅使代码更易于阅读和debugging，而且还可以在将来增加额外的属性。
请注意，数据首先被读入VBA数组; 处理; 结果放入另一个VBA数组，然后写入工作表。 此方法通常比重复访问每个单元格数据的工作表快5-10倍。
代码中的假设是每个“块”以列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
根据实际项目的需要，更改原始数据的工作表名称，结果以及结果范围（左上angular的单元格）。 我碰巧使用了Sheet2，列A：B中的原始数据，结果在E：H中。 请享用。