Microsoft Excel

Herbers Excel/VBA-Archiv

VBA: Wie geht das schneller

Betrifft: VBA: Wie geht das schneller von: Raphael H
Geschrieben am: 05.07.2013 19:57:11

Hallo zusammen,

ich nutze Momentan den unten angefügten Code um ein Tabellenblatt zu kopieren und dies unter einem Namen welcher in einer Zelle steht einzufügen.
Der Code ist allerdings sehr langsam, da er jedes Blatt anwählt um den Namen zu vergeben. Gibt es hier einen schnelleren und/oder besseren Ansatz?
Ich muss jedes Mal knapp 100 Blätter erstellen, dauert also ein Weilchen.

Sub Alle_Blätter_gem_Wohnen_1_erstellen()
Dim Kojen_Namen As Range
Dim Zelle As Variant

Set Kojen_Namen = Worksheets("Status").Range("C6:C114")

For Each Zelle In Kojen_Namen
On Error Resume Next
        i = Sheets.Count
        Worksheets("Wohnen 1").Copy After:=Sheets(i)
        ActiveSheet.Name = Zelle.Value
        Worksheets(Zelle.Value).Range("F1") = Zelle.Value

Next
End Sub
Besten Dank für eure Hilfe.

Gruess
Raphael

  

Betrifft: AW: VBA: Wie geht das schneller von: Martin
Geschrieben am: 06.07.2013 06:42:34

Hallo Raphael,

dein Code ist schon recht effizient und aus meiner Sicht nicht optimierbar. Du kannst lediglich die Bildschirm-Aktualisierung und Automatische Berechnung vorübergehend deaktivieren, das bringt sicherlich einen deutlichen Performance-Schub.

Sub Alle_Blätter_gem_Wohnen_1_erstellen()
    Dim Kojen_Namen As Range
    Dim Zelle As Variant
    
    Set Kojen_Namen = Worksheets("Status").Range("C6:C114")
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With

    
    For Each Zelle In Kojen_Namen
        On Error Resume Next
        i = Sheets.Count
        Worksheets("Wohnen 1").Copy After:=Sheets(i)
        ActiveSheet.Name = Zelle.Value
        Worksheets(Zelle.Value).Range("F1") = Zelle.Value
    Next

    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub

Viele Grüße

Martin



  

Betrifft: AW: VBA: Wie geht das schneller von: Matze Matthias
Geschrieben am: 06.07.2013 10:49:18

Hallo Raphael,
das berechnen dauert ja ne weile bis er die For Schleife durchlaufen hat,
hier eine etwas andere Schreibweise ohne die Variablen Kojen_Name und i

Sub kopieren()
  Dim rngC As Range
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual
  For Each rngC In Sheets("Status").Range("C6:C114")
    If rngC <> "" Then
      Sheets("Wohnen 1").Copy after:=Sheets(Sheets.Count)
      With ActiveSheet
        .Name = rngC
        .Range("F1") = rngC
      End With
    End If
  Next
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
End Sub



  

Betrifft: ...wenn schon denn schon... von: Martin
Geschrieben am: 06.07.2013 19:26:48

Hallo Matze,

noch besser ist...

Sub Alle_Blätter_gem_Wohnen_1_erstellen()
    Dim rngC As Range
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        For Each rngC In Sheets("Status").Range("C6:C114")
            If rngC <> "" Then
                Sheets("Wohnen 1").Copy after:=Sheets(Sheets.Count)
                With ActiveSheet
                    .Name = rngC
                    .Range("F1") = rngC
                End With
            End If
        Next
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
End Sub
Viele Grüße

Martin


  

Betrifft: AW: ...wenn schon denn schon... von: Raphael H
Geschrieben am: 07.07.2013 00:37:20

Hallo Martin, Hallo Matze,

besten Dank für Eure Hilfe, der Code ist jetzt um vieles schneller als vorher. Ich habe zu Euren Versionen nochmals einen kleinen kniff gefunden die Performance zu steigern.

Wenn man den Sheets.Count nur einmal vor der eigentlichen Schleife macht und danach immer +1 zählen lässt spart man nochmals einige Sekunden.

Sub Alle_Blätter_gem_Wohnen_1_erstellen()

Dim Zelle As Range
Dim i As Integer

With Application
    .ScreenUpdating = False
    .Calculation = xlCalculationManual
    .EnableEvents = False
    i = Sheets.Count
    For Each Zelle In Worksheets("Status").Range("C6:C114")
        If Zelle <> "" Then
            Worksheets("Wohnen 1").Copy After:=Sheets(i)
                With ActiveSheet
                    .Name = Zelle
                    .Range("F1") = Zelle
                End With
            i = i + 1
        End If
    Next
    .ScreenUpdating = True
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
End With
End Sub
Nochmals besten Dank
Gruess
Raphael