如何將數據從行格式化爲列

Question

我可以在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 

Answer 1

我很好奇，所以我試圖模擬天生的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