Bitte um ein Makro das Daten kopiert und löscht
02.12.2019 20:21:36
Christian
würde mich freuen, wenn ihr mir mit einem kleinen, hoffentlich nicht allzu aufwändigem Makro aushelft.
Ich habe 2 Blätter,
eins mit dem Namen Ergebnis, das andere mit dem Namen U18.
Beide haben keine Überschriften und 10 Spalten.
Folgendes würde ich mir nun wünschen.
1. Der Inhalt von U18 soll ausgeschnitten und am Ende des bestehenden Inhalts der Tabelle Ergebnis eingefügt werden
2. dann soll das bereits bestehende Makro3 ausgeführt werden.
3. dann sollen alle Zeilen in Tabelle Ergebnis, in denen eine Zahl zwischen 1 und 17 steht (in Spalte J) ausgeschnitten und in U18 eingefügt werden.
4. Die dann leeren Zeilen in Ergebnis sollen gelöscht werden.
5. Das Makro3 soll ein weiteres mal ausgeführt werden.
Hier noch das Makro3. Wenn ihr es für sinnvoller haltet, das Makro3 entsprechend zu erweitern, nehme ich natürlich auch eine solche Lösung.
Danke
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).Formula = .Range("E2:F" & loLetzte).Value2
.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, 5).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