Makro verbessern ?
06.08.2014 08:54:58
walter
ich habe mir folgendes Makro zusammengebastelt.
Das Makro läuft soweit und macht alles was ich wollte.
Nun dauert es allerdings sehr lange, vielleicht kann jemand
mal schauen, was man verbessern kann !!!
Würde mich freuen.
mfg
Walter mb
Das wird durch das Makro ausgeführt:
Von der Masterdatei aus wird eine neue Datei erstellt und
von der Tabelle 1+ 2 werden die vorhandenen Daten der Tabelle 1+2 aus der
Masterdatei in die neue Datei kopiert.
Ferner noch die Zeilen 1-9, wegen Formatierung etc.
Der Name wird mittels UF Textzeile festgelegt.
Private Sub CommandButton5_Click()
Dim lngReturn As Long
Dim DateiNam As String
Dim mb
Dim akt As String
Dim Neut As String
Dim shn As String
Dim shn2 As String
akt = ActiveWorkbook.Name
mb = UF_P.TextBox1.Text
Workbooks.Add
ChDir "C:\##_Muster"
' Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:=mb, FileFormat:=xlNormal, _
Password:="", WriteResPassword:="", ReadOnlyRecommended:=False
' Application.DisplayAlerts = True
' Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'Application.Calculation = xlCalculationAutomatic
Neut = ActiveWorkbook.Name ' neu gespeicherte Tabelle Namen: mb
Workbooks(akt).Activate ' zurück zur aktuellen Tabelle
Cells.Select
Selection.Copy
Workbooks(Neut).Activate
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Workbooks(akt).Activate
Application.CutCopyMode = False
'---- so jetzt Zeile 1 bis 9 kopieren ----
ActiveSheet.Rows("1:9").Select
Selection.Copy
Workbooks(Neut).Activate
ActiveSheet.Rows("1:1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("a:a").ColumnWidth = 1
Columns("b:b").ColumnWidth = 10
Columns("c:c").ColumnWidth = 20
Columns("d:d").ColumnWidth = 10
Columns("E:E").ColumnWidth = 35
Columns("f:f").ColumnWidth = 10
Columns("G:G").ColumnWidth = 5
Columns("H:H").ColumnWidth = 20
'----------- jetzt noch Tabellen Namen vergeben ------------------------
ActiveSheet.Name = ActiveSheet.Range("E3").Value
Workbooks(akt).Activate
Sheets(2).Select
Cells.Select
Selection.Copy
Workbooks(Neut).Activate
Sheets(2).Select
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:= _
xlNone, SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
Sheets(1).Select
'---- so jetzt Zeile 1 bis 9 kopieren ----
ActiveSheet.Rows("1:9").Select
Selection.Copy
Sheets(2).Select
ActiveSheet.Rows("1:1").Select
ActiveSheet.Paste
Application.CutCopyMode = False
Columns("a:a").ColumnWidth = 1
Columns("b:b").ColumnWidth = 10
Columns("c:c").ColumnWidth = 20
Columns("d:d").ColumnWidth = 10
Columns("E:E").ColumnWidth = 35
Columns("f:f").ColumnWidth = 10
Columns("G:G").ColumnWidth = 5
Columns("H:H").ColumnWidth = 20
ActiveSheet.Name = ActiveSheet.Range("E3").Value & "+AV"
Workbooks(akt).Activate ' zurück zur Ausgangs-Tabelle
Sheets("Account Allocation").Select
Cells.Select
Selection.Copy
Workbooks(Neut).Activate
Sheets(3).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Name = "aktuelle Daten"
ActiveSheet.Range("B3:F3").Select
Selection.AutoFilter
Workbooks(akt).Activate ' zurück zur Ausgangs-Tabelle
Sheets(1).Select
'Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
Unload Me
End Sub