Macro schöner oder schneller machen
28.12.2015 01:41:32
Thomas
ich habe mir mal das Macro zusammengestrickt. Es funktioniert eigentlich auch.
Aber ich wollte mal fragen ob man es auch schöner oder schneller darstellen kann.
Es soll die spalten h,k,D,b,z und cn (ohne formeln aber mit allen formaten )kopieren und anschließend sollen nur die spalten von A:F nach Spalte A ( hat überschrift) aufsteigend sortiert werden.
Und als letztes sollen alle zeilen gelöscht werden in denen in der Spalte 3 der wert grösser ist als 1. ( Ich glaub das dauert am längsten).
Muss mann alle schritte nacheinander so machen? Oder kann man das mit den Werte -Formaten einfügen und das sortieren in einem Schritt ( im Speicher) erledigen?
Eventuell geht das ja mit dem bedingten zeilen löschen anders?
liebe grüsse thomas
Option Explicit
Sub AAA_nur_Spalten_kopieren()
On Error GoTo ErrExit
Application.DisplayAlerts = False
Sheets("temp").Columns("a:F").Clear
Sheets("Vorgang").Columns("h").Copy
Sheets("temp").Columns("A").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("A").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("k").Copy
Sheets("temp").Columns("B").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("B").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("D").Copy
Sheets("temp").Columns("C").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("C").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("B").Copy
Sheets("temp").Columns("D").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("D").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Application.CutCopyMode = False
Sheets("Vorgang").Columns("Z").Copy
Sheets("temp").Columns("E").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("E").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
Sheets("Vorgang").Columns("CN").Copy
Sheets("temp").Columns("F").PasteSpecial Paste:=xlValues
Sheets("temp").Columns("F").PasteSpecial Paste:=xlPasteFormats 'Formate einfuegen
'############ ab hier sortieren mit recorder
ActiveWorkbook.Worksheets("temp").Columns("A:F").Select
ActiveWorkbook.Worksheets("temp").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("temp").Sort.SortFields.Add Key:=Columns( _
"A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("temp").Sort
.SetRange Columns("A:F")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A2").Select
Application.DisplayAlerts = True
' alle Zeilen löschen wenn wert in spalte 3 grösser als 1 ist
Dim LoLetzte As Long
Dim LoI As Long
Dim RaZeile As Range
LoLetzte = IIf(IsEmpty(Range("a65536")), Range("a65536").End(xlUp).Row, 65535) ' in B muss _
ein Wert stehen bei veränderung 65535 anpassen spaltenanzahl
'' !!!!!!!! in spalte 1 muss ein Wert stehen
If LoLetzte
Sub ' was passiert hier?
' = LoLetzte To 2 beginne Zeile 2
For LoI = LoLetzte To 2 Step -1
' 1 Then
' If Cells(LoI, 2 bedeutet in der 2. spalte
If RaZeile Is Nothing Then
Set RaZeile = Rows(LoI)
Else
Set RaZeile = Union(RaZeile, Rows(LoI))
End If
End If
Next LoI
If Not RaZeile Is Nothing Then RaZeile.Delete
Set RaZeile = Nothing
Application.CutCopyMode = False
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "Fehler im Modul Spalten'" & vbLf & String(60, "_") _
& vbLf & vbLf & _
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
_
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
_
vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - daten"
.Clear
End If
End With
On Error GoTo 0
End Sub