如果公式解决方案不符合您的要求，这是一种VBA解决方案。
我已将代码分为几个小块，以便可以分别进行解释。我包含Debug.Print命令，因此您可以了解每个块的功能。我希望我对权利有一定的解释。
Option Explicit
' "Option Explicit" means you have to explicitly declare every variable
' but you will get a "variable not declared" warning if you try to run
' your code with a misspelt variable.
Sub Rearrange()
Dim ColOldCrnt As Integer
Dim ColOldMax As Integer
Dim RowCrnt As Long ' Long in case there are more than 32767 rows
Dim RowMax As Long ' Use same row variable for both sheets
Dim SheetOld() As Variant
' The first block of code (down to "Debug.Assert False") assumes your
' current list is in worksheet "Sheet1". Change the "With Sheets()"
' command as necessary.
' The code finds the bottommost row and the rightmost column and then
' loads the entire rectangle to array SheetOld. It is much faster using an
' array than accessing individual cells as necessary.
With Sheets("Sheet1")
RowMax = .Cells.Find("*", .Range("A1"), xlFormulas, , _
xlByRows, xlPrevious).Row
ColOldMax = .Cells.Find("*", .Range("A1"), xlFormulas, , _
xlByColumns, xlPrevious).Column
SheetOld = .Range(.Cells(1, 1), .Cells(RowMax, ColOldMax)).Value
End With
Debug.Print "Max row = " & RowMax
Debug.Print "Max col = " & ColOldMax
Debug.Print "First 15 rows from old sheet"
For RowCrnt = 1 To 15
For ColOldCrnt = 1 To ColOldMax
' With two dimensional arrays it is normal to have the column as the
' first dimension. With arrays loaded from a worksheet, the row is
' the first dimension.
Debug.Print "|" & SheetOld(RowCrnt, ColOldCrnt);
Next
Debug.Print "|"
Next
Debug.Assert False ' This stops the routine until you press continue (F5)
' Press Ctrl+G if you cannot see the Immediate Window.
' Normally I would put all the variables as the top but I want to discuss each
' block's variables separately.
' This block builds in array "ListName()" a list of all the names. The list
' is in the order in which names are found. If you have a mispelt name (for
' example: "Lsit1") you will get a column for "Lsit1". You may have to run
' the routine, correct any mispelt names and then rerun.
' This is not top quality code. I have had to compromise between good
' and easy to understand. I hope I have the balance right.
Dim Found As Boolean
Dim InxNameCrnt As Integer
Dim InxNameCrntMax As Integer
Dim NameList() As String
Dim NameCrnt As String
' Using constants makes the code a little easier to understand.
' I use the same constants for both the old and new sheets because
' the important columns are in the same sequence.
Const ColFirstList As Integer = 4
ReDim NameList(1 To 100) ' Bigger than could be necessary
InxNameCrntMax = 0
For RowCrnt = 2 To RowMax
For ColOldCrnt = ColFirstList To ColOldMax
' Get a name out of the array and trim any leading
' or trailing spaces
NameCrnt = Trim(SheetOld(RowCrnt, ColOldCrnt))
If NameCrnt <> "" Then
Found = False
' Search the current list for this name
For InxNameCrnt = 1 To InxNameCrntMax
If NameList(InxNameCrnt) = NameCrnt Then
' This name already recorded
Found = True
Exit For ' Exit search
End If
Next
If Not Found Then
' Add this name to the end of the list
InxNameCrntMax = InxNameCrntMax + 1
NameList(InxNameCrntMax) = NameCrnt
End If
End If
Next
Next
Debug.Print "Names in order found:"
For InxNameCrnt = 1 To InxNameCrntMax
Debug.Print "|" & NameList(InxNameCrnt);
Next
Debug.Print "|"
Debug.Assert False ' This stops the routine until you press continue (F5)
' The next block builds the output worksheet in array SheetNew().
' I have used "Given" and "Family" instead of "Name" and "Surname" so I
' can reserve "Name" for the list names.
Const ColGiven As Integer = 1
Const ColFamily As Integer = 2
Const ColEmail As Integer = 3
Dim ColNewCrnt As Integer
Dim ColNewMax As Integer
Dim SheetNew() As String
' One column for the columns to the left of the first name and then
' one per name.
ReDim SheetNew(1 To RowMax, 1 To ColFirstList - 1 + InxNameCrntMax)
' Copy across columns heading for the first columns
For ColNewCrnt = 1 To ColFirstList - 1
SheetNew(1, ColNewCrnt) = SheetOld(1, ColNewCrnt)
Next
' Head the remaining columns with name
For InxNameCrnt = 1 To InxNameCrntMax
SheetNew(1, ColFirstList - 1 + InxNameCrnt) = NameList(InxNameCrnt)
Next
Debug.Print "First row from new sheet:"
For RowCrnt = 1 To 1
For ColNewCrnt = 1 To UBound(SheetNew, 2)
Debug.Print "|" & SheetNew(RowCrnt, ColNewCrnt);
Next
Debug.Print "|"
Next
Debug.Assert False ' This stops the routine until you press continue (F5)
' This block copies information from the old sheet to the new sheet
For RowCrnt = 2 To RowMax
' Copy the initial columns unchanged
For ColNewCrnt = 1 To ColFirstList - 1
SheetNew(RowCrnt, ColNewCrnt) = SheetOld(RowCrnt, ColNewCrnt)
Next
For ColOldCrnt = ColFirstList To ColOldMax
' Get a name out of the old sheet and trim any leading
' or trailing spaces
NameCrnt = Trim(SheetOld(RowCrnt, ColOldCrnt))
If NameCrnt <> "" Then
Found = False
' Search the current list for this name
For InxNameCrnt = 1 To InxNameCrntMax
If NameList(InxNameCrnt) = NameCrnt Then
' Name found
Found = True
Exit For ' Exit search
End If
Next
Debug.Assert Found ' Name found on first pass but not second
' Program error
SheetNew(RowCrnt, ColFirstList - 1 + InxNameCrnt) = "Yes"
End If
Next
Next
Debug.Print "First 15 rows from new sheet:"
For RowCrnt = 1 To 15
For ColNewCrnt = 1 To UBound(SheetNew, 2)
Debug.Print "|" & SheetNew(RowCrnt, ColNewCrnt);
Next
Debug.Print "|"
Next
Debug.Assert False ' This stops the routine until you press continue (F5)
' This code assumes the destination sheet is "Sheet2". Change the
' "With Sheets()" command if necessary
With Sheets("Sheet2")
.Cells.EntireRow.Delete ' Remove everything for the sheet
.Rows(1).Font.Bold = True ' Set the top row to bold
'Load the worksheet from the array
.Range(.Cells(1, 1), .Cells(RowMax, UBound(SheetNew, 2))).Value = SheetNew
End With
' I have not bothered about column widths and the columns are in the
' sequence found. You could add a dummy row at the top of the old sheet
' for John Doe who gets every list in the sequence you require. Alternately
' you could sort the rows by hand.
End Sub
我希望这一切都有意义。如果您使用这种方法，那么最好。
