ein Makro um ein paar kleine Dinge erweitern
27.04.2019 19:15:06
Christian
ich würde mich freuen, wenn ihr mir unten stehendes Makro um ein paar Dinge erweitert,
sind ein paar Punkte aber ich denke nichts, wofür ein VBA Profi lange brauchen würde.
Ich habe 2 Tabellen, eine heißt Ergebnis und in dieser steht auch das Makro und die andere heißt vorher.
Ziel des ganzen ist, die Spalte J zu vergleichen, in wiefern sich in Spalte J etwas durch das Ausführen des bisherigen Makros geändert hat.
das Makro soll jetzt folgendes tun:
1. den bisherigen Inhalt von "vorher" löschen.
2. den Inhalt von "Ergebnis" nach "vorher" kopieren um die Kopie zum späteren Vergleich zu erstellen, dabei in "vorher" anstatt der Formeln die Werte einfügen. (Formeln stehen ausschließlich in Zeile 1).
3. das bisherige Makro in "Ergebnis" ausführen.
4. beide Tabellen neu sortieren, beide Tabellen mit dem ersten Kriterium Spalte A aufsteigend, 2. Kriterium Spalte D aufsteigend.
5. in Spalte L der Tabelle vorher die Formel
=UND(REST(J1;1)=0;J1>=1;J1UND(REST(Ergebnis!J1;1)=0;Ergebnis!J1>=1;Ergebnis!J16. Alle Zeilen in Tabelle "vorher" löschen, in denen die Formel FALSCH ausgegeben hat.
7. Die Tabelle "Ergebnis" wieder so sortieren, wie sie durch das bisherige Makro schonmal sortiert wurde.
Würde mich sehr freuen wen das jemand für mich umsetzt.
Danke
Christian
Sub Makro3()
Dim loLetzte As Long, j As Long, x 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").Copy .Range("E2:E" & loLetzte)
.Range("E2:E" & loLetzte).Copy
.Range("E2:E" & loLetzte).PasteSpecial xlPasteValues
.Range("K1").Copy .Range("K1:K" & loLetzte)
.Range("K2:K" & loLetzte).Copy
.Range("K2:K" & loLetzte).PasteSpecial xlPasteValues
.Columns("K:K").Copy
.Columns("F:F").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
.Range("L1") = "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:L" & loLetzte)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'Zeile der Markierung in Spalte l suchen
x = .Cells(Rows.Count, 12).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, 5).Copy .Range("G1")
.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).Value = .Range("G2:J" & loLetzte).Value
.Cells(x, 12) = Empty 'markierung löschen
.Range("E2").Select
End With
End Sub