kleine Frage zu Änderung eines Makros
06.12.2015 19:16:36
Jenny
habe mal eine kurze Frage,
zu diesem Teil meines Makros:
'Daten sortieren
If Zeile_L >= 3 Then
With .Range(.Rows(1), .Rows(Zeile_L))
.Sort key1:=.Range("C1"), order1:=xlAscending, _
key2:=.Range("G1"), order2:=xlDescending, Header:=xlYes
End With
End If
'Formeln kopieren
.Range(.Cells(1, 2), .Cells(1, 4)).Copy
.Range(.Cells(2, 2), .Cells(Zeile_L, 4)).PasteSpecial Paste:=xlPasteFormulas
.Range(.Cells(1, 8), .Cells(1, 13)).Copy
.Range(.Cells(2, 8), .Cells(Zeile_L, 13)).PasteSpecial Paste:=xlPasteFormulas
'Formeln kopieren
.Range(.Cells(1, 2), .Cells(1, 4)).Copy
.Range(.Cells(2, 2), .Cells(Zeile_L, 4)).PasteSpecial Paste:=xlPasteFormulas
'Daten sortieren
If Zeile_L >= 3 Then
With .Range(.Rows(1), .Rows(Zeile_L))
.Sort key1:=.Range("C1"), order1:=xlAscending, _
key2:=.Range("G1"), order2:=xlDescending, Header:=xlYes
End With
End If
'Formeln kopieren
.Range(.Cells(1, 8), .Cells(1, 13)).Copy
.Range(.Cells(2, 8), .Cells(Zeile_L, 13)).PasteSpecial Paste:=xlPasteFormulas
Hier noch das komplette Makro zur Übersicht:
Sub SortierenBerechenKopieren()
Dim wks1 As Worksheet, wks2 As Worksheet
Dim Zeile_L As Long, StatusCalc As Long
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
'Tabellen-Objekte setzen
Set wks1 = Worksheets("Tabelle1")
Set wks2 = Worksheets("Tabelle6")
'In Tabelle6 alles löschen
With wks2
.UsedRange.Clear
End With
With wks1 'Tabelle1
'Letzte Zeile mit Daten in Spalte A
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile_L >= 2 Then
'Daten sortieren
If Zeile_L >= 3 Then
With .Range(.Rows(1), .Rows(Zeile_L))
.Sort key1:=.Range("C1"), order1:=xlAscending, _
key2:=.Range("G1"), order2:=xlDescending, Header:=xlYes
End With
End If
'Formeln kopieren
.Range(.Cells(1, 2), .Cells(1, 4)).Copy
.Range(.Cells(2, 2), .Cells(Zeile_L, 4)).PasteSpecial Paste:=xlPasteFormulas
.Range(.Cells(1, 8), .Cells(1, 13)).Copy
.Range(.Cells(2, 8), .Cells(Zeile_L, 13)).PasteSpecial Paste:=xlPasteFormulas
'Hilfsformeln in Spalte O einfügen - Spalte L = 3 Then
With .Range(.Rows(1), .Rows(Zeile_L))
.Sort key1:=.Range("O1"), order1:=xlAscending, _
key2:=.Range("C1"), order1:=xlAscending, _
key3:=.Range("G1"), order2:=xlDescending, Header:=xlYes
End With
End If
'In Hilfsspalte alle Zeilen mit WAHR kopieren nach Tabelle6
With .Range(.Cells(2, 15), .Cells(Zeile_L, 15))
If Application.WorksheetFunction.CountIf(.Cells, True) > 0 Then
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Copy wks2.Cells(1, 1) '4 = xlLogical
End If
End With
'Tabelle1 Sortierung Rückgängig machen
If Zeile_L >= 3 Then
With .Range(.Rows(1), .Rows(Zeile_L))
.Sort key1:=.Range("P1"), order1:=xlAscending, Header:=xlYes
End With
End If
'Hilfsspalten wieder löschen
.Range("O:P").EntireColumn.Delete
End If
End With 'wks1
With wks2 'Tabelle6
'Letzte Zeile mit Daten in Spalte A
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
If Zeile_L >= 2 Then
'Tabelle6 Sortierung nach Spalte P
With .Range(.Rows(1), .Rows(Zeile_L))
.Sort key1:=.Range("P1"), order1:=xlAscending, Header:=xlNo
End With
With .Range(.Cells(1, 15), .Cells(Zeile_L, 15))
'Hilfsformeln in Spalte O einfügen - Markiert doppelte in Spalte A mit WAHR
.FormulaR1C1 = "=IF(countif(R1C1:RC1,RC1)>1,True,"""")"
.Calculate
.Copy
.PasteSpecial Paste:=xlPasteValues
'Zeilen mit WAHR in Spalte O löschen
If Application.WorksheetFunction.CountIf(.Cells, True) > 0 Then
.SpecialCells(xlCellTypeConstants, 4).EntireRow.Delete
End If
End With
End If
'Hilfsspalten wieder löschen
.Range("O:P").EntireColumn.Delete
'Spalten E:M löschen
.Range("E:M").EntireColumn.Delete
.Activate
End With 'wks2
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End Sub
Jenny