Langsames Makro

Hallo Zusammen
Meine Markos laufen sehr langsam. Eigentlich bestehen die nur aus Button wählen und Filtern. Also keine grosse Sache. Aber die benötigen immer etwa 20-30 Sekunden.
Hier mal das Makro. Vielleicht hat jemand eine Idee zur Optimierung.
Sub Suchmaschiene()
'
' Suchmaschiene Makro
'
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=26, Criteria1:="0"
AnzahlTreffer = Application.WorksheetFunction.Subtotal(3, Range("c:c")) - 1
MsgBox ("Insgesamt " & AnzahlTreffer & " Treffer gefunden.")
Range("O7").Select
Selection.ClearContents
Application.Calculation = xlCalculationAutomatic
End Sub Sub Deutsch()
Application.Calculation = xlCalculationManual
Range("B2").Select
ActiveCell.FormulaR1C1 = "Offerten & Submissionen"
Range("C13").Select
ActiveCell.FormulaR1C1 = "KW"
Range("D13").Select
ActiveCell.FormulaR1C1 = "Datum"
Range("e13").Select
ActiveCell.FormulaR1C1 = "Offerte Nr."
Range("f13").Select
ActiveCell.FormulaR1C1 = "Typ"
Range("g13").Select
ActiveCell.FormulaR1C1 = "GVA"
Range("h13").Select
ActiveCell.FormulaR1C1 = "Unternehmer"
Range("i13").Select
ActiveCell.FormulaR1C1 = "Komm."
Range("j13").Select
ActiveCell.FormulaR1C1 = "Händler"
Range("K13").Select
ActiveCell.FormulaR1C1 = "PLZ"
Range("l13").Select
ActiveCell.FormulaR1C1 = "Objektort"
Range("m13").Select
ActiveCell.FormulaR1C1 = "Objektbezeichnung"
Range("n13").Select
ActiveCell.FormulaR1C1 = "Teilmarkt"
Range("o13").Select
ActiveCell.FormulaR1C1 = "Produkte"
Range("P13").Select
ActiveCell.FormulaR1C1 = "Menge"
Range("q13").Select
ActiveCell.FormulaR1C1 = "Netto Fr."
Range("r13").Select
ActiveCell.FormulaR1C1 = "Brutto Fr."
Range("s13").Select
ActiveCell.FormulaR1C1 = "Summe Fr. 5'000.-"
Range("t13").Select
ActiveCell.FormulaR1C1 = "Rabatt Unternehmer"
Range("u13").Select
ActiveCell.FormulaR1C1 = "Rabatt Händler"
Range("v13").Select
ActiveCell.FormulaR1C1 = "Kommentar/Aufgaben"
Range("w13").Select
ActiveCell.FormulaR1C1 = "Termin"
Range("x13").Select
ActiveCell.FormulaR1C1 = "Verantw."
Range("N8").Select
ActiveCell.FormulaR1C1 = "Setzen Sie den Stern (*)nur, wenn Sie vage nach etwas suchen (zB. Strassennamen, Firma). Für die Suche von Angebote, Postleitzahl und Orte ist der Stern (*) nicht erforderlich! Wenn Sie einen PLZ benötigen, zeigt das System auch die Mengen an (zB. 3250 Aarberg, Fr. 3'250)."
Range("N4").Select
ActiveCell.FormulaR1C1 = "Suchmaschine"
Range("O6").Select
ActiveCell.FormulaR1C1 = "Suchkriterium"
ActiveSheet.Shapes.Range(Array("TextBox 2")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "GVA (Gebietsverantwortlicher)"
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3).Font
.NameComplexScript = "Arial"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Name = "Arial"
End With
ActiveSheet.Shapes.Range(Array("TextBox 36")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Alle"
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 4). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignLeft
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 4).Font
.NameComplexScript = "Arial"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Name = "Arial"
End With
Range("B2").Select
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Französisch()
Application.Calculation = xlCalculationManual
Range("B2").Select
ActiveCell.FormulaR1C1 = "Offres & Soummissions"
Range("C13").Select
ActiveCell.FormulaR1C1 = "S"
Range("D13").Select
ActiveCell.FormulaR1C1 = "Date"
Range("e13").Select
ActiveCell.FormulaR1C1 = "Offre N°"
Range("f13").Select
ActiveCell.FormulaR1C1 = "Type"
Range("g13").Select
ActiveCell.FormulaR1C1 = "RDS"
Range("h13").Select
ActiveCell.FormulaR1C1 = "Entrepreneur"
Range("i13").Select
ActiveCell.FormulaR1C1 = "Comm."
Range("j13").Select
ActiveCell.FormulaR1C1 = "Marchand"
Range("K13").Select
ActiveCell.FormulaR1C1 = "CP"
Range("l13").Select
ActiveCell.FormulaR1C1 = "Chantier"
Range("m13").Select
ActiveCell.FormulaR1C1 = "Désignation d'objet"
Range("n13").Select
ActiveCell.FormulaR1C1 = "Sous-marchés"
Range("o13").Select
ActiveCell.FormulaR1C1 = "Produits"
Range("P13").Select
ActiveCell.FormulaR1C1 = "Quantité"
Range("q13").Select
ActiveCell.FormulaR1C1 = "Net CHF."
Range("r13").Select
ActiveCell.FormulaR1C1 = "Brut CHF"
Range("s13").Select
ActiveCell.FormulaR1C1 = "Somme CHF. 5'000.-"
Range("t13").Select
ActiveCell.FormulaR1C1 = "Rabais entrepreneur"
Range("u13").Select
ActiveCell.FormulaR1C1 = "Rabais marchand"
Range("v13").Select
ActiveCell.FormulaR1C1 = "Commentaire/Tâches"
Range("w13").Select
ActiveCell.FormulaR1C1 = "Délai"
Range("x13").Select
ActiveCell.FormulaR1C1 = "Resp."
Range("N8").Select
ActiveCell.FormulaR1C1 = "Vous devez mettre les *(astérisque)uniquement si vous cherchez quelque chose d'imprécis (ex : nom de rue, entreprise). Pour les n°d'offres, code postaux et lieux, l'*(astérisque) n'est pas nécessaire ! Si vous cherchez un CP, le système montre également les montants (ex : 3250 Aarberg, 3'250CHF)."
Range("N4").Select
ActiveCell.FormulaR1C1 = "Moteur de recherche"
Range("O6").Select
ActiveCell.FormulaR1C1 = "Rechercher"
ActiveSheet.Shapes.Range(Array("TextBox 2")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "RDS (Responsables de secteur)"
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignCenter
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 3).Font
.NameComplexScript = "Arial"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Name = "Arial"
End With
ActiveSheet.Shapes.Range(Array("TextBox 36")).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = "Toutes"
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 4). _
ParagraphFormat
.FirstLineIndent = 0
.Alignment = msoAlignLeft
End With
With Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 4).Font
.NameComplexScript = "Arial"
.NameFarEast = "+mn-ea"
.Fill.Visible = msoTrue
.Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
.Fill.ForeColor.TintAndShade = 0
.Fill.ForeColor.Brightness = 0
.Fill.Transparency = 0
.Fill.Solid
.Size = 10
.Name = "Arial"
End With
Range("B2").Select
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Antonio_Gullà()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="1"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Antonio Gullà"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Céderic_Clerc()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="2"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Céderic Clerc"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Antoine_Berthoud()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="3"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Antoine Berthoud"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub John_Jutzet()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="4"
Range("B10").Select
ActiveCell.FormulaR1C1 = "John Jutzet"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Jürg_Staudenmann()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="5"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Jürg Staudenmann"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Jürg_Mathys()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="6"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Jürg Mathys"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub André_Mercerat()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="7"
Range("B10").Select
ActiveCell.FormulaR1C1 = "André Mercerat"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Reto_Reinhard()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="9"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Reto Reinhard"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Reto_ReinhardW()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="W"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Reto Reinhard"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Pierre_Grandjean()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="17"
Range("B10").Select
ActiveCell.FormulaR1C1 = "Pierre Grandjean"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub CH()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:="CH"
Range("B10").Select
ActiveCell.FormulaR1C1 = "CH"
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Alle()
Application.Calculation = xlCalculationManual
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=5, Criteria1:=""
Range("B10").Select
ActiveCell.FormulaR1C1 = ""
Application.Calculation = xlCalculationAutomatic
End Sub
Sub Akutalisieren()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Selection.AutoFilter
Range("C15:AB15").Select
Range("AB15").Activate
Selection.AutoFilter
ActiveSheet.Range("$C$15:$AB$9007").AutoFilter Field:=25, Criteria1:="offen"
Range("B2").Select
ActiveWorkbook.Worksheets("OFFERTEN-OFFRES").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("OFFERTEN-OFFRES").AutoFilter.Sort.SortFields.Add _
Key:=Range("L15:L9007"), SortOn:=xlSortOnValues, Order:=xlAscending, _
DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("OFFERTEN-OFFRES").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("O7").Select
Selection.ClearContents
Range("B10").Select
Selection.ClearContents
Application.Calculation = xlCalculationAutomatic
End Sub
Sub SendenPDf()
Dim app As Object
Dim file As String
Dim isNew As Boolean
file = ActiveSheet.Name & ".pdf"
ActiveSheet.ExportAsFixedFormat xlTypePDF, Environ("TEMP") & "\" & file
On Error Resume Next
Set app = GetObject(, "Outlook.Application")
If app Is Nothing Then
Set app = CreateObject("Outlook.Application")
isNew = True
End If
With app.CreateItem(0)
.to = ""
.Subject = Range("B10") & " Offerten/Offres" & Format(Date, " DD.MM.YYYY")
.Attachments.Add Environ("TEMP") & "\" & file
.Display 'Email anzeigen
End With
If isNew Then app.Quit
End Sub

Private Sub WorkSheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column = 8 And Target.Row = 13 Then
Worksheets("Unternehmerliste").Range("$A$1:$B$23252").AutoFilter Field:=2, Criteria1:="  _
_
0"
Cancel = True
Range("H14").Select
Selection.ClearContents
Sheets("Unternehmerliste").Select
End If
If Target.Column = 10 And Target.Row = 13 Then
Worksheets("Händler").Range("$A$1:$B$142").AutoFilter Field:=2, Criteria1:="0"
Cancel = True
Range("J14").Select
Selection.ClearContents
Sheets("Händler Liste").Select
End If
If Target.Column = 9 And Target.Row = 13 Then
Worksheets("Kommision").Range("$d$1:$e$23252").AutoFilter Field:=2, Criteria1:="0"
Cancel = True
Range("I30").Select
Selection.ClearContents
Sheets("Kommisions Liste").Select
End If
If Target.Column = 5 And Target.Row = 13 Then
Worksheets("OFFERTEN-OFFRES").Range("$C$15:$AB$9007").AutoFilter Field:=1, Criteria1:="="
Cancel = True
End If
End Sub

Vielen Dank im voraus.
Gruss
Defence

Forumthread: Langsames Makro

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Langsames Makro

Forumthread: Langsames Makro

3 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

3
Beiträge zum Forumthread

Beiträge zu diesem Forumthread