Tabulate тестов

Question

Я работаю на VBA код и хотел бы сделать следующее:

Read:

A  B 
1 John 100 
2 Jill 90 
3 John 95 
4 Amy 82 

Изменение к (в алфавитном порядке):

A B C 
1 Amy 82 
2 Jill 90 
3 John 100 95 

В конце концов я вам нужно отобразить имя ученика и все оценки рядом с именем.

До сих пор у меня есть это:

Sub Combine() 

Dim J As Integer 
Dim wrk As Workbook 'Workbook object - Always good to work with object variables 
Dim wrk1 As Worksheet 
Dim r1, r2, r3, r4, r5, r6, r7, ra, rb, rc, rd, re, rf, rg As Range 
Sheets("Sheet2").Select 
Set r1 = Range("D:D") 
Set r2 = Range("B:B") 
Set r3 = Range("E:E") 
Set r4 = Range("C:C") 
Set r5 = Range("F:F") 
Set r6 = Range("H:H") 
Set r7 = Range("AX:AX") 
Sheets("Sheet3").Select 
Set ra = Range("D:D") 
Set rb = Range("B:B") 
Set rc = Range("E:E") 
Set rd = Range("C:C") 
Set re = Range("F:F") 
Set rf = Range("H:H") 
Set rg = Range("AX:AX") 

Set wrk = Workbooks.Add 

ActiveWorkbook.Sheets(2).Activate 

r1.Copy Range("A1") 
r2.Copy Range("B1") 
r3.Copy Range("C1") 
r4.Copy Range("D1") 
r5.Copy Range("E1") 
r6.Copy Range("F1") 
r7.Copy Range("G1") 

ActiveWorkbook.Sheets(3).Activate 

ra.Copy Range("A1") 
rb.Copy Range("B1") 
rc.Copy Range("C1") 
rd.Copy Range("D1") 
re.Copy Range("E1") 
rf.Copy Range("F1") 
rg.Copy Range("G1") 

On Error Resume Next 
Sheets(1).Select 
Sheets(1).Name = "Combined" 
Sheets(2).Activate 
Range("A2").EntireRow.Select 
Selection.Copy Destination:=Sheets(1).Range("A1") 
For J = 2 To Sheets.Count 
Sheets(J).Activate 
Range("A3").Select 
Selection.CurrentRegion.Select 
Selection.Offset(1, 0).Resize(Selection.Rows.Count - 1).Select 
Selection.Copy Destination:=Sheets(1).Range("A65536").End(xlUp)(2) 

Sheets(1).Select 

Range("A1:AY100").Sort _ 
Key1:=Range("C1"), Key2:=Range("B1"), Header:=xlYes 



Next 



End Sub 

Answer 1

Я хотел бы создать сводную таблицу для вашего случая. Легко создавать, обновления легко и удобно поддерживать. Однако здесь приведен фрагмент кода:

Sub pivotDataInColumns() 
    Dim sourceSheet As Excel.Worksheet 
    Dim destinationSheet As Excel.Worksheet 
    Dim sourceRow As Long 
    Dim destinationRow As Long 
    Dim matchRow As Long 
    Dim searchColumn As Excel.Range 
    Dim nameToFind As String 
    Dim lastColumn As Long 

    Application.ScreenUpdating = False 

    With ThisWorkbook 
     'Change Worksheet name to suit: 
     Set sourceSheet = ThisWorkbook.Worksheets("Sheet1") 
     Set destinationSheet = ThisWorkbook.Worksheets.Add 
    End With 
    Set searchColumn = destinationSheet.Columns("A") 

    For sourceRow = 1 To getLastRow(sourceSheet.Columns("A")) 
     nameToFind = sourceSheet.Cells(sourceRow, "A").Value 

     destinationRow = getMatchRow(nameToFind, searchColumn) 
     If destinationRow = 0 Then 
      destinationRow = getLastRow(destinationSheet.Columns("A")) + 1 
      destinationSheet.Cells(destinationRow, "A").Value = sourceSheet.Cells(sourceRow, "A").Value 
     End If 

     lastColumn = getLastColumn(destinationSheet.Rows(destinationRow)) + 1 
     destinationSheet.Cells(destinationRow, lastColumn).Value2 = sourceSheet.Cells(sourceRow, "B").Value2 
    Next sourceRow 

    'Remove row 1 garbage and sort: 
    With destinationSheet 
     .Rows(1).Delete 
     .UsedRange.Sort Key1:=.Range("A1"), _ 
         Order1:=xlAscending, _ 
         Header:=xlNo 
    End With 

    Application.ScreenUpdating = True 

    MsgBox "Data processed successfully.", vbInformation 
End Sub 

Private Function getMatchRow(searchValue As Variant, _ 
          searchArray As Variant) As Long 
    'This function returns 0 if searchValue is not on searchArray. 

    Dim element As Long 

    On Error Resume Next 
    element = WorksheetFunction.Match(CDbl(searchValue), searchArray, 0) 
    If element = 0 Then element = WorksheetFunction.Match(CStr(searchValue), searchArray, 0) 

    getMatchRow = element 
End Function 

Private Function getLastRow(sourceRange As Excel.Range) As Long 
    Dim parentSheet As Excel.Worksheet 
    Dim lastRow As Long 

    Set parentSheet = sourceRange.Parent 
    With parentSheet 
     lastRow = .Cells(.Rows.Count, sourceRange.column).End(xlUp).row 
    End With 

    getLastRow = lastRow 
End Function 

Private Function getLastColumn(sourceRange As Excel.Range) As Long 
    Dim parentSheet As Excel.Worksheet 
    Dim lastColumn As Long 

    Set parentSheet = sourceRange.Parent 
    With parentSheet 
     lastColumn = .Cells(sourceRange.row, .Columns.Count).End(xlToLeft).column 
    End With 

    getLastColumn = lastColumn 
End Function