使用vba从添加标题的范围中复制值并按大小在Excel中排序

我有一个从 B5 到 R20 的表格，每一行都有一个标题，并不是范围内的每个单元格（标题除外）都有值。表看起来像这样： John empty empty 2 5 300... Steve empty 23 45 130... Todd 100 123 150 170... ... 名称是标题，而不是零，有空单元格。我需要在新列（AJ 列）中复制这些值，并且我需要复制每个值旁边的适当标题（标题值在列 AI 中）。复制后，这两列应按 AJ 列降序排序。到目前为止我有这个：

Sub Sorter()

Dim g As Integer
Dim sourceCol As Integer
Dim rowCount As Integer
Dim currentRow As Integer
Dim currentRowValue As String
Dim sourceCol1 As Integer
Dim rng1 As Range
Dim t As Integer

sourceCol = 35
sourceCol1 = sourceCol + 1
rowCount = 300

t = 5
    For g = 1 To 16
            Set rng1 = Range(Rows(t).Cells(3), Rows(t).Cells(18))
            If rng1.Cells(g) > 0 Then

            For currentRow = 1 To rowCount
                currentRowValue = Cells(currentRow, sourceCol).Value
                If IsEmpty(currentRowValue) Or currentRowValue = "" Then
                    Cells(t, 2).Select
                    Selection.Copy
                    Cells(currentRow, sourceCol).PasteSpecial xlPasteValues
                    Cells(t, g).Select
                    Selection.Copy
                    Cells(currentRow, sourceCol1).PasteSpecial xlPasteValues
                End If
            Next currentRow
            End If
            t = t + 1
        Next g

' This part sorts the two columns
Columns("AI:AJ").Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range( _
    "AJ1:AJ300"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
    xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
    .SetRange Range("AI1:AJ300")
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
End With

Kraj:
End Sub

所以，排序部分正在工作，但复制部分给我带来了问题。我被卡住了，你能帮忙吗？结果应该是：

    AI     AJ
    John   300
    Todd   170
    Todd   150
    Steve  130
    ... etc