我可以在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
我很好奇，所以我试图模拟天生的Transpose -function：
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
这当然是可能的VBA来完成。但我宁愿建议尝试使用Pivot Table。 –
是的，你可以。您的信息不足以让我直接指导您如何做到这一点，但假设您只有类型1且名称相同。您应该做的唯一的事情就是将最后2列即问答的数据进行TRANSPOSE。为此，代码是：'Application.WorksheetFunction.Transpose（rng）'其中'rng'是最后2列中的数据范围 – Ibo
要添加到lbo的评论中，您必须选择等于行和列将被转置。写公式'=移调（移位单元格的范围）'，然后按下'Ctrl + Shft + Enter'将其变成数组公式，以使该功能起作用。 –