製表考試成績

Question

我工作的VBA代碼，想做到以下幾點：

閱讀：

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