我可以在R中完成此任务，但我的工作讨厌除excel之外的所有其他程序。我知道excel有VBA但老实说我不明白。是否有代码可以格式化这些数据而无需手动移动它？
编辑：我添加到我的数据中，表明基本上每个姓名都被要求列出他们拥有的每个帐户并回答7个问题。答案可能因文本框而异。当前数据
Name Acct Question Answer
ABC 1 1 A
ABC 1 2 A
ABC 1 3 A
ABC 1 4 A
ABC 1 5 A
ABC 1 6 A
ABC 1 7 A
ABC 2 1 A
ABC 2 2 A
ABC 2 3 A
ABC 2 4 A
我需要它看起来像这样。
Name Type 1 2 3 4 5 6 7
ABC 1 A A A A A A A
ABC 2 A A A A A A A
答案 0 :(得分：0)
我很好奇，所以我试图模仿Transpose - 函数：
Option Explicit
Option Base 1
' Q at https://stackoverflow.com/questions/46610421/how-to-format-data-from-rows-to-columns
'
' How I understand the needed functionality :
'
' 1. search for all seperate names in 'Name'
' -> create rows with for different found names
' -> and for each found name seperate rows for each 'Acct/Type'
' 2. search in 'Acct' for the highest number
' -> number of rows for each seperate 'Name'
' 3. search in 'Question' for the highest number
' -> create column headers as many as the highest number
' 4. search for 'Answer' for the combination 'Name/Acct/Question'
' -> put result in 'Name/Type/column-number'
' 5. by NOT using the function 'Transpose', this functionality allows
' -> to have different number of answers to the questions
' ( see example on the bottom of the code in 'vba_window_direct_v01' )
'
Public Sub f11()
Const initValue As String = "-init-"
Dim Cell
Dim SourceRange As Range
Dim TargetRange As Range
Dim SourceNames() As String
Dim CurrentValue As String
Dim PreviousValue As String
Dim ArrayIndex As Long
Dim RowCount As Long
Dim MaxAcct As Long
Dim MaxQuestionNumber As Long
Dim AcctOrTypeCounter As Long
Dim QuestionCounter As Long
Dim SourceTable_FirstCell_Address As String
Dim TargetTable_FirstCell_Address As String
Sheets("Page03").Select ' select the worksheet whit the data
Sheets("Page03").Activate ' so ActiveSheet is where I perform the functionality
SourceTable_FirstCell_Address = "B3" ' my location for 'Name' of the source-table
TargetTable_FirstCell_Address = "G3" ' my location for 'Name' of the target-table
'
' select first column with the different names
'
Set SourceRange = Range(SourceTable_FirstCell_Address)
' to avoid processing too much empty rows, only select the rows from 'CurrentRegion'
RowCount = SourceRange.CurrentRegion.Rows.Count
Set SourceRange = Range(SourceRange, SourceRange.Offset(RowCount, 0))
' if too much rows, warn the user
If RowCount > 100 Then
If MsgBox("are you sure to process " & RowCount & " rows ?" & vbCrLf & _
"It could take a while ;-)", vbYesNo + vbDefaultButton2) vbYes Then
End
End If
End If
'
' loop thru the first column
'
CurrentValue = ""
PreviousValue = ""
ReDim Preserve SourceNames(1) ' need to initialise to 1, otherwise UBound will return an error
SourceNames(1) = initValue ' put a value in this, in order to be able to test if array is empty or so
'
For Each Cell In SourceRange
CurrentValue = Cell.Value
If CurrentValue PreviousValue Then
If CurrentValue "" And CurrentValue "Name" Then
SourceNames(UBound(SourceNames)) = CurrentValue
ReDim Preserve SourceNames(UBound(SourceNames) + 1)
SourceNames(UBound(SourceNames)) = initValue
PreviousValue = CurrentValue
End If
End If
Next
'
' print out array with found names
'
For ArrayIndex = LBound(SourceNames) To UBound(SourceNames)
Debug.Print "'" & ArrayIndex & " : " & SourceNames(ArrayIndex)
Next
'
' second column // 'Acct' or 'Type'
'
Set SourceRange = Range(SourceTable_FirstCell_Address)
Set SourceRange = SourceRange.Offset(0, 1) ' go to next column
Set SourceRange = SourceRange.Offset(1, 0) ' this column starts with 'Acct', so go to next row
' this RowCount will have a too high value, but, the essence is, we are not processing 10.000+ rows ;-)
RowCount = SourceRange.CurrentRegion.Rows.Count
Set SourceRange = Range(SourceRange, SourceRange.Offset(RowCount, 0))
'
MaxAcct = 0
For Each Cell In SourceRange
CurrentValue = Cell.Value
If Val(CurrentValue) > MaxAcct Then
MaxAcct = Val(CurrentValue)
End If
Next
'
Debug.Print "' Max number of Acct or Type : " & MaxAcct
'
' thirth column // 'Question'
'
Set SourceRange = Range(SourceTable_FirstCell_Address)
Set SourceRange = SourceRange.Offset(0, 2) ' go to thirth column
Set SourceRange = SourceRange.Offset(1, 0) ' this column starts with 'Question', so go to next row
' this RowCount will have a too high value, but, the essence is, we are not processing 10.000+ rows ;-)
RowCount = SourceRange.CurrentRegion.Rows.Count
Set SourceRange = Range(SourceRange, SourceRange.Offset(RowCount, 0))
'
MaxQuestionNumber = 0
For Each Cell In SourceRange
CurrentValue = Cell.Value
If Val(CurrentValue) > MaxQuestionNumber Then
MaxQuestionNumber = Val(CurrentValue)
End If
Next
Debug.Print "' Max number of Question : " & MaxQuestionNumber
'
' first, clear out old results
'
Set TargetRange = Range(TargetTable_FirstCell_Address)
Set TargetRange = TargetRange.CurrentRegion
Application.CutCopyMode = False
TargetRange.Delete Shift:=xlToLeft
'
' create a TargetTable like 'Name/Type/1..MaxQuestionNumber'
'
Set TargetRange = Range(TargetTable_FirstCell_Address)
TargetRange.FormulaR1C1 = "Name"
Set TargetRange = TargetRange.Offset(0, 1)
TargetRange.FormulaR1C1 = "Type"
For ArrayIndex = 1 To MaxQuestionNumber
Set TargetRange = TargetRange.Offset(0, 1)
TargetRange.FormulaR1C1 = ArrayIndex
Next
'
' create the rows with the 'Name' and 'Type' in the TargetTable
'
Set TargetRange = Range(TargetTable_FirstCell_Address)
Set TargetRange = TargetRange.Offset(1, 0) ' skip title 'Name', go to next row
For ArrayIndex = LBound(SourceNames) To UBound(SourceNames)
Debug.Print "'" & ArrayIndex & " : " & SourceNames(ArrayIndex)
If SourceNames(ArrayIndex) = initValue Then
' skip / exit
Exit For
Else
For AcctOrTypeCounter = 1 To MaxAcct
TargetRange.Value = SourceNames(ArrayIndex)
TargetRange.Offset(0, 1).Value = AcctOrTypeCounter
Set TargetRange = TargetRange.Offset(1, 0) ' go to next row
Next
End If
Next
'
' Now copying the values of the answers from the sourcetable to the targettable
'
Set SourceRange = Range(SourceTable_FirstCell_Address)
Set SourceRange = SourceRange.Offset(1, 0)
Do While SourceRange.Offset(0, 3).Value ""
'Debug.Print "'Source 0,3 := " & SourceRange.Offset(0, 3).Value
' go to the right name
Set TargetRange = Range(TargetTable_FirstCell_Address)
Do While TargetRange.Value SourceRange.Offset(0, 0).Value
Set TargetRange = TargetRange.Offset(1, 0)
Loop
' go to the right Acct/Type
If Val(SourceRange.Offset(0, 1)) > 1 Then
For AcctOrTypeCounter = 2 To Val(SourceRange.Offset(0, 1))
Set TargetRange = TargetRange.Offset(1, 0)
Next
End If
' go to the wright column with the question-number
Set TargetRange = TargetRange.Offset(0, 1) ' first go from column with 'Name' to 'Type'
For AcctOrTypeCounter = 1 To Val(SourceRange.Offset(0, 2))
Set TargetRange = TargetRange.Offset(0, 1)
Next
'TargetRange.Select
TargetRange.Value = SourceRange.Offset(0, 3).Value
' select next row / select next answer
Set SourceRange = SourceRange.Offset(1, 0)
Loop
' set font to 'courier new' and align horizontally to the center
Set TargetRange = Range(TargetTable_FirstCell_Address)
Set TargetRange = TargetRange.CurrentRegion
TargetRange.Font.Name = "Courier New"
TargetRange.HorizontalAlignment = xlCenter
End Sub
Public Sub vba_window_direct_v01()
' Sample Table, added some lines with 'DEF' and 'GHI'
' Numbers behind each answers are only to keep track of the working of the function
'Name Acct Question Answer
'ABC 1 1 A1
'ABC 1 2 A2
'ABC 1 3 A3
'ABC 1 4 A4
'ABC 1 5 A5
'ABC 1 6 A6
'ABC 1 7 A7
'ABC 2 1 A8
'ABC 2 2 A9
'ABC 2 3 A10
'ABC 2 4 A11
'DEF 1 6 B12
'DEF 1 7 B13
'DEF 1 8 B14
'DEF 2 1 B15
'DEF 2 2 B16
'GHI 1 1 C17
'GHI 2 1 C18
'GHI 3 1 C19
'GHI 3 2 C20
' Sample of table with transposed results
'Name Type 1 2 3 4 5 6 7 8
'ABC 1 A1 A2 A3 A4 A5 A6 A7
'ABC 2 A8 A9 A10 A11
'ABC 3
'DEF 1 B12 B13 B14
'DEF 2 B15 B16
'DEF 3
'GHI 1 C17
'GHI 2 C18
'GHI 3 C19 C20
End Sub