Makro sortiert nicht wie gewünscht
05.09.2019 21:35:41
Christian
wie bereits angesprochen, sortiert mein Makro nicht wie gewünscht, habe auch eine Vermutung weshalb, nur leider habe ich nicht genug Ahnung von VBA um das Problem eigenständig zu beheben und bitte daher um eure Hilfe:
Lange rede kurzer Sinn, die Formel in F1 hat beim kopieren und danach Werte einfügen Zellen erzeugt, die zwar leer aussehen, aber nicht mehr leer sind, da das Formelergebnis "" als Wert eingefügt wurde.
Ist es möglich, dass das Makro bevor es sortiert erstmal alle Inhalte in Spalte F bei denen das passiert ist wieder löscht, damit die Tabelle so sortiert wird als hätte in diesen Zellen nie eine Formel gestanden?
Danke für eure Hilfe
Christian
Sub Makro3()
Dim loLetzte As Long, j As Long, x As Long, lC As Long
Application.ScreenUpdating = False
With Worksheets("Ergebnis")
loLetzte = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("B1:C1").Copy .Range("B1:C" & loLetzte)
.Range("B2:C" & loLetzte).Copy
.Range("B2:C" & loLetzte).PasteSpecial xlPasteValues
.Range("E1:F1").Copy .Range("E2:F" & loLetzte)
.Range("E2:F" & loLetzte).Copy
.Range("E2:F" & loLetzte).PasteSpecial xlPasteValues
.Range("K1") = "Formel" 'Zeile 1 markieren!!
.Sort.SortFields.Clear
.Sort.SortFields.Add Key:=.Range("C1:C" & loLetzte), SortOn:=xlSortOnValues, _
Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add Key:=.Range("F1:F" & loLetzte), SortOn:=xlSortOnValues, _
Order:=xlDescending, DataOption:=xlSortNormal
With .Sort
.SetRange Range("A1:K1" & loLetzte)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Zeile der Markierung in Spalte l suchen
x = .Cells(Rows.Count, 11).End(xlUp).Row
'Formeln ggf. in Zeile1 zurück kopieren
If x > 1 Then
.Cells(x, 2).Resize(1, 2).Copy .Range("B1")
.Cells(x, 7).Resize(1, 6).Copy .Range("E1")
.Cells(x, 5).Copy .Range("E1")
.Rows(x).Value = .Rows(x).Value
End If
.Range("G1:J1").Copy .Range("G2:J" & loLetzte)
.Range("G2:J" & loLetzte).Copy
.Range("G2:J" & loLetzte).PasteSpecial xlPasteValues
.Cells(x, 11) = Empty 'markierung löschen
.Range("E2").Select
End With
Application.CutCopyMode = False
End Sub