Vereinfachung VBA Code

Hallo Leute,
ich habe ein Excel VBA Code geschrieben, der auch soweit läuft. Leider erscheint mir der Code recht kompliziert und er lässt sich insgesamt bestimmt vereinfachen.

Sub ML_Liste_importieren_und_PSP_Elemente_sortieren()
' ML_Liste_importieren Makro
Application.ScreenUpdating = False
Sheets("ML-Liste").Select
Cells.Select
Selection.ClearContents
Workbooks.Open Filename:= _
"G:\Liste.xlsm", Notify:=False
Cells.Select
Selection.Copy
Windows("kalkulation.xlsm").Activate
Sheets("Liste").Range("A1").Select
ActiveSheet.Paste
ActiveSheet.Cells(1, 1).Select
'   Einfuegen von leerer Spalte AG fuer PSP Element ohne Praefix
Range("AG31").Select
ActiveCell.FormulaR1C1 = "=MID(RC[-7],5,19)"
Selection.AutoFill Destination:=Range("AG31:AG4000")
Range("AG31:AG4000").Select
Range("AH31").Select
ActiveCell.FormulaR1C1 = "=RC[-17]"
Selection.AutoFill Destination:=Range("AH31:AH4000")
Range("AG30").Value = "Element"
Range("AH30").Value = "umfang"
'   Format übertragen
Range("AF30").Select
Selection.Copy
Range("AG30").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("AF30").Select
Selection.Copy
Range("AH30").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Range("AF31").Select
Selection.Copy
Range("AG31:AH31").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Selection.AutoFill Destination:=Range("AG31:AH4000")
Call Loeschen_Zwischenablage
Windows("Liste.xlsm").Activate
ActiveWindow.Close
ActiveWorkbook.Worksheets("Gesamtstunden").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Gesamtstunden").AutoFilter.Sort.SortFields.Add  _
Key:= _
Range("L1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Gesamtstunden").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ActiveWorkbook.Worksheets("kalkulation").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("kalkulation").AutoFilter.Sort.SortFields.Add Key:= _
Range("M1"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("kalkulation").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Sheets("kalkulation").Select
Application.ScreenUpdating = True
End Sub

Mich würde interessieren, mit welchen Mitteln ich den Code verkürzen und das Makro beschleunigen kann. Vielen Dank im Voraus für jeden Tipp und Hinweis. Dass .Selecet und .Activate große Zeitfresser sind, habe ich bereits erfahren, jedoch tue ich mich schwer damit, in dem Code drauf zu verzichten.

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Paul,
ich hab leider nicht die Zeit um deinen Code umzuschreiben, aber ich kann dir einen Tipp bezüglich der .select geben, welche wirklich selten nötig sind.
Dein Code:

Range("AF30").Select
Selection.Copy
Range("AH30").Select
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

Dein Code ohne .select:

Range("AF30").Copy
Range("AG30").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False

willst du mit dem PasteSpecial ohne Formeln (also nur werte) kopieren? dann gehts so noch schneller:

Range("AF30").Copy
Range("AG30").PasteSpecial Paste:=xlValues

vllt kommst du ja damit schon weiter, ich lass deinen Beitrag aber mal offen, falls jmd anders dir helfen will/Zeit hat
Gruß Stefan

Sub importieren_sortieren() Dim WB1 As Workbook, WB2 As Workbook Dim WS1 As Worksheet, WS2 As Worksheet Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Set WB1 = ThisWorkbook Set WS1 = WB1.Worksheets("Liste") Set WB2 = Workbooks.Open(Filename:="G:\Liste.xlsm", _ Notify:=False) Set WS2 = WB2.Worksheets("Tabelle1") With WS1 .UsedRange.ClearContents WS2.UsedRange.Copy .Range("A1") .Range("AG31:AG4000").FormulaR1C1 = "=MID(RC[-7],5,19)" .Range("AH31:AH4000").FormulaR1C1 = "=RC[-17]" .Range("AG30").Value = "Teil Element" .Range("AH30").Value = "Fertigungsumfang" .Range("AF30").Copy .Range("AG30:AH30").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False .Range("AF31").Copy .Range("AG31:AH31").PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _ SkipBlanks:=False, Transpose:=False End With Call Loeschen_Zwischenablage WB2.Close False With ThisWorkbook.Worksheets("Gesamtstunden") .AutoFilter.Sort.SortFields.Clear .AutoFilter.Sort.SortFields.Add Key:=.Range("L1"), SortOn:=xlSortOnValues, _ Order:=xlDescending, DataOption:=xlSortNormal With .AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With With ThisWorkbook.Worksheets("kalkulation") .AutoFilter.Sort.SortFields.Clear .AutoFilter.Sort.SortFields.Add Key:=.Range("M1"), SortOn:=xlSortOnValues, _ Order:=xlDescending, DataOption:=xlSortNormal With .AutoFilter.Sort .Header = xlYes .MatchCase = False .Orientation = xlTopToBottom .SortMethod = xlPinYin .Apply End With End With Application.CutCopyMode = False Application.Calculation = xlCalculationAutomatic End Sub

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Vereinfachung VBA Code

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

304 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread