Makro verbessern ???

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Informationen und Beispiele zum Thema CommandButton
Screenshot zu CommandButton	CommandButton-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema TextBox
Screenshot zu TextBox	TextBox-Seite mit Beispielarbeitsmappe aufrufen

Makro verbessern ???

Makro verbessern ??? von walter mb vom 06.08.2014 08:54:58

AW: Makro verbessern ??? - von Daniel am 06.08.2014 09:05:55
AW: Makro verbessern ??? - von Robert am 06.08.2014 09:17:08
- Fehlermeldung - von walter mb am 06.08.2014 09:28:20
AW: Makro verbessern ??? - von Rudi Maintaire am 06.08.2014 11:29:51
- Das geht nicht weil... - von walter mb am 06.08.2014 13:13:00
  - Super Geil habe es .... -) - von walter mb am 06.08.2014 14:03:35
  - dann kannst du doch ... - von Rudi Maintaire am 06.08.2014 16:09:05
    - Danke Rudi für das Beispiel -)) - von Kurt am 06.08.2014 16:19:08
      - Dein Beispiel Rudi ist Spitze ! DANKE -)) - von walter mb am 06.08.2014 16:40:16
        
        Rudi bitte nochmal kurz... - von walter mb am 06.08.2014 16:52:20
        
        lies mal deine Frage .... - von Rudi Maintaire am 06.08.2014 17:01:14
        
        Hast leider RECHT - von walter mb am 06.08.2014 21:32:19
        
        Danke habe so gemacht... --)) - von walter mb am 07.08.2014 10:20:44
        
        Du sollst nicht SELECTen!!! - von Rudi Maintaire am 07.08.2014 12:35:16

Betrifft: Makro verbessern ??? von: walter mb
Geschrieben am: 06.08.2014 08:54:58

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

Betrifft: AW: Makro verbessern ??? von: Daniel
Geschrieben am: 06.08.2014 09:05:55

Hi
Erstmal die Selects und Activates eliminieren, weitere Infos dazu hier:
http://www.online-excel.de/excel/singsel_vba.php?f=78
Gruß Daniel

Betrifft: AW: Makro verbessern ??? von: Robert
Geschrieben am: 06.08.2014 09:17:08

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

Betrifft: Fehlermeldung von: walter mb
Geschrieben am: 06.08.2014 09:28:20

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

Betrifft: AW: Makro verbessern ??? von: Rudi Maintaire
Geschrieben am: 06.08.2014 11:29:51

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

Betrifft: Das geht nicht weil... von: walter mb
Geschrieben am: 06.08.2014 13:13:00

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

Betrifft: Super Geil habe es .... -) von: walter mb
Geschrieben am: 06.08.2014 14:03:35

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

Betrifft: dann kannst du doch ... von: Rudi Maintaire
Geschrieben am: 06.08.2014 16:09:05

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

Betrifft: Danke Rudi für das Beispiel -)) von: Kurt
Geschrieben am: 06.08.2014 16:19:08

Hallo Rudi,
sehr nett, danke für das Beispiel.
Werde nachher mal testen.
MfG
Walter mb

Betrifft: Dein Beispiel Rudi ist Spitze ! DANKE -)) von: walter mb
Geschrieben am: 06.08.2014 16:40:16

Betrifft: Rudi bitte nochmal kurz... von: walter mb
Geschrieben am: 06.08.2014 16:52:20

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

Betrifft: lies mal deine Frage .... von: Rudi Maintaire
Geschrieben am: 06.08.2014 17:01:14

Hallo,
.... und sag mir dann, ob du das verstehst!

Gruß
Rudi

Betrifft: Hast leider RECHT von: walter mb
Geschrieben am: 06.08.2014 21:32:19

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

Betrifft: Danke habe so gemacht... --)) von: walter mb
Geschrieben am: 07.08.2014 10:20:44

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

Betrifft: Du sollst nicht SELECTen!!! von: Rudi Maintaire
Geschrieben am: 07.08.2014 12:35:16

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

Herbers Excel/VBA-Archiv

Der kurze Weg zum Ziel: Auftragsprogrammierung

Makro verbessern ???