Kopieren von Werten aus einem Bereich mit Kopfzeile und Sortieren nach Größe in Excel mit Vba

Question

Ich habe eine Tabelle von B5 bis R20, jede Zeile hat eine Kopfzeile und nicht jede Zelle im Bereich (außer Kopfzeilen) hat Werte. Tabelle sieht so aus: John leer leer 2 5 300 ... Steve leer 23 45 130 ... Todd 100 123 150 170 ... ... Namen sind Header und anstelle von Nullen gibt es leere Zellen. Ich muss diese Werte in eine neue Spalte (Spalte AJ) kopieren und ich muss die entsprechende Kopfzeile neben jedem Wert kopieren (Header-Wert geht in Spalte AI). Nach der Kopie sollten diese zwei Spalten absteigend nach AJ-Spalte sortiert werden. Ich habe dies so weit:

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 

So ist der Sortierabschnitt funktioniert, aber das Kopieren Teil mir Probleme gibt. Ich stecke fest, also kannst du bitte helfen? Das Ergebnis sollte sein:

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

Answer 1

eine mögliche Lösung zu testen.

Sub Sorter() 
    Dim g As Integer 
    Dim sourceCol As Integer 
    Dim rowCount As Integer 
    Dim currentRow As Integer 
    Dim targetrow As Long 
    Dim currentRowValue As String 
    Dim sourceCol1 As Integer 
    Dim rng1 As Range 
    Dim t As Integer 

    sourceCol = 35 
    sourceCol1 = sourceCol + 1 
    rowCount = 300 
    targetrow = 1 
    t = 5 
    With ActiveWorkbook.Worksheets("Sheet1") 
     While .Cells(t, 1) <> "" 
      For g = 2 To 17 
       If .Cells(t, g) > 0 Then 
        targetrow = targetrow + 1 
        .Cells(targetrow, sourceCol) = .Cells(t, 1) 
        .Cells(targetrow, sourceCol1) = .Cells(t, g) 
       End If 
      Next g 
      t = t + 1 
     Wend 
     ' This part sorts the two columns 
     With .Sort 
      .SortFields.Clear 
      .SortFields.Add Key:=Range("AJ1:AJ300"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal 
      .SetRange Range("AI1:AJ300") 
      .Header = xlGuess 
      .MatchCase = False 
      .Orientation = xlTopToBottom 
      .SortMethod = xlPinYin 
      .Apply 
     End With 
    End With 
End Sub