Laufzeit Makro ist zu lange

Hallo Forum,
ich habe mir über viele Jahre hinweg eine Excelliste gebastelt und über verschiedenen Quellen ein Makro gebastelt.
Dieses Makro füllt Eingabewerte aus einer User Form in eine Zeile, dort werden dann über verschiedene Formeln weitere Werte ergänzt und dann kopiert das Makro diese Zeile an das Ende einer Tabelle. Soweit so gut und hat auch immer fumktioniert.
Jetzt möchte ich aber diese Arbeitsmappe auch anderne Personen zugänglich machen und habe das Makro um einen Blattschutz erweitert in dem der Autofilter aber immer noch funktionieren soll.
Das Ergebnis ist: Das Makro macht was es soll allerdings ist die Laufzeit >5sec.
Daher meine Frage: "Wo kann hier noch etwas Geschwindigkeit gutmacht werden, ohne das Makro grundlegend zu ändern?"

Private Sub CommandButton2_Click() 'Lieferschein erfassen'

Dim Blatt As Worksheet
For Each Blatt In ActiveWorkbook.Sheets
Blatt.Unprotect ("123")
Next

Dim lngIndex As Long
For lngIndex = 1 To 6
If Controls("TextBox" & CStr(lngIndex)).TextLength = 0 Then
MsgBox "Es sind ein oder mehrere Felder nicht ausgefüllt!", vbOKOnly Or vbCritical, "Eingabefehler"
Exit Sub
End If
Next

Dim inta As Integer
Set frm = UserForm1
Sheets("Admin").Activate
With frm

Cells(3, 10).Value = .TextBox1.Value
Cells(3, 1).Value = DateValue(TextBox2)
Cells(3, 2).Value = CDbl(TextBox3.Value)
Cells(3, 4).Value = CDbl(TextBox4.Value)
Cells(3, 12).Value = .TextBox5.Value
Cells(3, 13).Value = .TextBox6.Value
End With

Worksheets("Admin").Range("A3:W3").Copy
Zeile = Worksheets("Erfassung").Range("A65535").End(xlUp).Row
If Application.IsText(Worksheets("Erfassung").Cells(Zeile, 1)) Then Zeile = Zeile + 1 Else _
Zeile = Zeile + 1

Worksheets("Erfassung").Cells(Zeile, 1).PasteSpecial Paste:=xlPasteValues

Dim tb As Object
For Each tb In UserForm1.Controls
TextBox4.Text = ""
TextBox5.Text = ""
TextBox6.Text = ""
TextBox3.SetFocus
Next tb

inta = MsgBox("Der Lieferschein wurde übernommen!", vbOKOnly + vbInformation, "Erfolgreiche Eingabe")

ActiveSheet.Unprotect
Range("O3:W3").Select
Selection.ClearContents

Sheets("Admin").Visible = xlVeryHidden

For Each Blatt In ActiveWorkbook.Sheets
Blatt.Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True
Next

UserForm1.Hide

Sheets("Erfassung").Activate

UserForm1.Show

End Sub

Vielen Dank schon mal und wie gesagt das Makro macht was es soll ich weiß hatl nur nicht so recht wieso :-)
Gruss Thomas

Hallo
Teste dies mal , von mir ungetestet

Private Sub CommandButton2_Click() 'Lieferschein erfassen'

Dim tb As Object

Dim data As Variant

Dim Zeile As Long

Dim inta As Integer

Dim lngIndex As Long

    Application.ScreenUpdating = False

    Application.Calculation = xlCalculationManual

    Application.EnableEvents = False

    Worksheets("Erfassung").Unprotect ("123")

    For lngIndex = 1 To 6

        If Controls("TextBox" & CStr(lngIndex)).TextLength = 0 Then

            MsgBox "Es sind ein oder mehrere Felder nicht ausgefüllt!", vbOKOnly Or vbCritical, "Eingabefehler"

            Exit Sub

        End If

    Next

    Set frm = UserForm1

    With Worksheets("Admin")

        .Cells(3, 10).Value2 = frm.TextBox1.Value

        .Cells(3, 1).Value2 = DateValue(frm.TextBox2)

        .Cells(3, 2).Value2 = CDbl(frm.TextBox3.Value)

        .Cells(3, 4).Value2 = CDbl(frm.TextBox4.Value)

        .Cells(3, 12).Value2 = frm.TextBox5.Value

        .Cells(3, 13).Value2 = frm.TextBox6.Value

    End With

    Zeile = Worksheets("Erfassung").Cells(Worksheets("Erfassung").Rows.Count, 1).End(xlUp).Row + 1

    data = Worksheets("Admin").Cells(3, 1).Resize(1, 23).Value2

    Worksheets("Erfassung").Cells(Zeile, 1).Resize(1, 23).Value2 = data

    For Each tb In UserForm1.Controls

        If TypeName(tb) = "TextBox" Then tb.Text = ""

    Next tb

    inta = MsgBox("Der Lieferschein wurde übernommen!", vbOKOnly + vbInformation, "Erfolgreiche Eingabe")

    Worksheets("Admin").Range("O3:W3").ClearContents

    Worksheets("Admin").Visible = xlVeryHidden

    Worksheets("Erfassung").Protect Password:="123", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFiltering:=True

    UserForm1.Hide

    Worksheets("Erfassung").Activate

    UserForm1.Show

    Application.ScreenUpdating = True

    Application.Calculation = xlCalculationAutomatic

    Application.EnableEvents = True

End Sub

Forumthread: Laufzeit Makro ist zu lange

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Laufzeit Makro ist zu lange

Forumthread: Laufzeit Makro ist zu lange

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

VBA Beispiele zu diesem und ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

14
Beiträge zum Forumthread

Beiträge zu diesem Forumthread