Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1372to1376
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Makro verbessern ???

Makro verbessern ?
06.08.2014 08:54:58
walter
Guten Morgen zusammen,
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

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Makro verbessern ?
06.08.2014 09:17:08
Robert
Hallo Walter,
.Activate und .Select sind unter allen Umständen zu Vermeiden.
Nur mal das Gröbste Bereinigt:
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
Workbooks(akt).Tabelle1.Cells.Copy
Workbooks(Neut).Tabelle1.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Workbooks(akt).Tabelle1.Rows("1:9").Copy
Workbooks(Neut).Tabelle1.Rows("1:9").Paste
With Workbooks(Neut).Tabelle1
.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
.Name = .Range("E3").Value
End With
Workbooks(akt).Tabelle2.Cells.Copy
Workbooks(Neut).Tabelle2.Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Workbooks(Neut).Tabelle1.Rows("1:9").Copy
Workbooks(Neut).Tabelle2.Rows("1:9").Paste
With Worksheets(Neut).Tabelle2
.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
.Name = .Range("E3").Value & "+AV"
End With
Workbooks(akt).Sheets("Account Allocation").Cells.Copy
Workbooks(Neut).Tabelle3.Cells(1, 1).PasteSpecial
Workbooks(Neut).Tabelle3.Name = "aktuelle Daten"
Workbooks(Neut).Tabelle3.Range("B3:F3").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

Anzeige
Fehlermeldung
06.08.2014 09:28:20
walter
Hallo Daniel und Robert,
super Danke für die Unterstützung.
Leider kommt hier Fehlermeldung:
Workbooks(akt).Tabelle1.Cells.Copy
Laufzeitfehler 438
Objekt unterstützt diese Eigenschaft Methode nicht.
mfg
walter mb

AW: Makro verbessern ?
06.08.2014 11:29:51
Rudi
Hallo,
warum kopierst du nicht einfach die 3 Blätter in eine neue Datei?
etwa so:
Sub aaa()
Dim mb As String
mb = UF_P.TextBox1.Text
Sheets(Array(1, 2, "Account Allocation")).Copy
With ActiveWorkbook
With .Sheets(1)
.Name = .Range("E3")
End With
With .Sheets(2)
.Name = .Range("E3") & "+AV"
End With
With .Sheets("Account Allocation")
.Name = "Aktuelle Daten"
.Range("B3").AutoFilter
End With
.SaveAs "C:\##_Muster\" & mb, xlNormal
End With
End Sub
Gruß
Rudi

Anzeige
Das geht nicht weil...
06.08.2014 13:13:00
walter
Hallo Rudi,
ich darf nur die Werte und wollte auch die Zahlenformate kopieren.
Formel sollen nicht sichtbar sein und es ist zuviel Speicherverbrauch.
mfg
walter mb

Super Geil habe es .... -)
06.08.2014 14:03:35
walter
Hallo zusammen,
habe das Makro ein wenig geändert, funktioniert bestens.
Super Geil in 2 Sekunden !!!
Danke an ALLE für die Unterstützung !!!
akt = ActiveWorkbook.Name
mb = UF_Phil.TextBox1.Text
Workbooks.Add
ChDir "C:\"
' 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
'Workbooks(akt).Tabelle1.Cells.Copy 'mit fehlermeldung Laufzeitfehler 438
Workbooks(akt).Sheets(1).Cells.Copy
Workbooks(Neut).Sheets(1).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Workbooks(akt).Sheets(1).Rows("1:9").Copy 'für die Formatierung
Workbooks(Neut).Sheets(1).Paste
With Workbooks(Neut).Sheets(1)
.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
.Name = .Range("E3").Value
End With
Workbooks(akt).Sheets(2).Cells.Copy
Workbooks(Neut).Sheets(2).Cells(1, 1).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Workbooks(akt).Sheets(2).Rows("1:9").Copy 'für die Formatierung
Workbooks(Neut).Sheets(2).Paste
With Workbooks(Neut).Sheets(2)
.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
.Name = .Range("E3").Value & "+AV"
End With
Workbooks(akt).Sheets("aktuelle Datei").Cells.Copy
Workbooks(Neut).Sheets(3).Cells(1, 1).PasteSpecial ' Paste:=xlPasteValuesAndNumberFormats
' Workbooks(Neut).Tabelle3.Cells(1, 1).PasteSpecial
Workbooks(Neut).Sheets(3).Name = "aktuelle Datei"
Workbooks(Neut).Sheets(3).Range("B3:F3").AutoFilter
Workbooks(akt).Activate ' zurück zur Ausgangs-Tabelle
Sheets(1).Select
'Application.Calculation = xlCalculationManual
Application.Calculation = xlCalculationAutomatic
'Application.ScreenUpdating = True
Unload Me
mfg
walter mb

Anzeige
dann kannst du doch ...
06.08.2014 16:09:05
Rudi
Hallo,
... anschließend alles in Werte umwandeln.
Sub aaa()
Dim mb As String
mb = UF_P.TextBox1.Text
Sheets(Array(1, 2, "Account Allocation")).Copy
With ActiveWorkbook
With .Sheets(1)
.Name = .Range("E3")
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
With .Sheets(2)
.Name = .Range("E3") & "+AV"
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
End With
With .Sheets("Account Allocation")
.Name = "Aktuelle Daten"
.Cells.Copy
.Cells.PasteSpecial xlPasteValues
.Range("B3").AutoFilter
End With
.SaveAs "C:\##_Muster\" & mb, xlNormal
End With
End Sub

Gruß
Rudi

Anzeige
Danke Rudi für das Beispiel -))
06.08.2014 16:19:08
Kurt
Hallo Rudi,
sehr nett, danke für das Beispiel.
Werde nachher mal testen.
MfG
Walter mb

Dein Beispiel Rudi ist Spitze ! DANKE -))
06.08.2014 16:40:16
walter

Rudi bitte nochmal kurz...
06.08.2014 16:52:20
walter
Hallo Rudi,
das ist so sehr GUT.
Allerdings brauch ich die Formel aus der Zeile 8 für die neuen Dateien,
vom Orginal.
Brauch ich in der Sheet 1 in die Sheet 2, der neuen Datei.
Die Zeile 8 ist mit Summenformeln hinterlegt.
Kannst Du nochmal helfen, da deine Datei einfach Klasse ist.
mfg
walter mb

lies mal deine Frage ....
06.08.2014 17:01:14
Rudi
Hallo,
.... und sag mir dann, ob du das verstehst!
Gruß
Rudi

Hast leider RECHT
06.08.2014 21:32:19
walter
Hallo Rudi,
in der Zeile 8 in der Orginalsheet sind Summenformeln drin,
diese Formel brauch ich.
Diese Formel in
E8 =TEILERGEBNIS(3;$B10:$B$64999)
F8 =SUMME($F$10:$F$64832)
I8 =SUMMEWENN(I10:I64999;"#NV") bis AS8
AT8 =MITTELWERT($AT$10:$AT$64999)
AU =SUMMEWENN(AU10:AU64999;"#NV") bis BK8
mfg
walter mb

Anzeige
Danke habe so gemacht... --))
07.08.2014 10:20:44
walter
Guten Morgen Rudi,
habe so erstellt, funktioniert einwandfrei.
DANKE,
gruß
walter mb
ActiveSheet.Range("E8").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(3,R[2]C2:R65000C2)"
ActiveSheet.Range("F8").Select
ActiveCell.FormulaR1C1 = "=SUM(R10C6:R64833C6)"
ActiveSheet.Range("I8").Select
ActiveCell.FormulaR1C1 = "=SUMIF(R[2]C:R[64992]C,""#NV"")"
Range("I8").Select
Selection.AutoFill Destination:=Range("I8:BK8"), Type:=xlFillDefault ' BK ist 63 Spalte !!!!
ActiveSheet.Range("AT8").Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R10C46:R65000C46)"
Sheets(2).Select
ActiveSheet.Range("E8").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(3,R[2]C2:R65000C2)"
ActiveSheet.Range("F8").Select
ActiveCell.FormulaR1C1 = "=SUM(R10C6:R64833C6)"
ActiveSheet.Range("I8").Select
ActiveCell.FormulaR1C1 = "=SUMIF(R[2]C:R[64992]C,""#NV"")"
Range("I8").Select
Selection.AutoFill Destination:=Range("I8:BK8"), Type:=xlFillDefault ' BK ist 63 Spalte !!!!
ActiveSheet.Range("AT8").Select
ActiveCell.FormulaR1C1 = "=AVERAGE(R10C46:R65000C46)"
ActiveSheet.Range("B9").Select

Anzeige
Du sollst nicht SELECTen!!!
07.08.2014 12:35:16
Rudi
Hallo,
das ist das 1. Gebot. ;-)
Und ActiveSheet brauchst du auch nicht.
Statt
ActiveSheet.Range("E8").Select
ActiveCell.FormulaR1C1 = "=SUBTOTAL(3,R[2]C2:R65000C2)"

einfach
Range("E8").FormulaR1C1 = "=SUBTOTAL(3,R[2]C2:R65000C2)"

Gruß
Rudi

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige