Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
932to936
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
932to936
932to936
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Optimiterungspotentiale

Optimiterungspotentiale
19.12.2007 08:58:00
Salim
Hallo Zusammen,
ich habe folgendes Makro geschrieben (bitte um ein bisschen Gnade: siehe Level VBA bescheiden ;) )
Der Makro läuft auch. Der einzige negative Punkt ist dass unten links der Satz: Markieren Sie den Zellbereich und drücken Sie die Eingabetaste ständig blinkt. Ich kann es nicht nachvollziehen.
Gruss
Salim

Private Sub CommandButton1_Click()
Dim StBerechnung As Integer
StBerechnung = Application.Calculation ' Berechnungsmodus speichern
Application.Calculation = xlManual ' Berechnungsmodus manuell
Me.Hide
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Tabelle1").Unprotect
Worksheets("Tabelle1").Cells.Replace What:="Tabelle2!", Replacement:="Standardblatt!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:= _
False
With ThisWorkbook
For Each Worksheet In .Sheets
If Worksheet.Name = "Tabelle2" Then
Sheets("Tabelle2").Delete
End If
Next Worksheet
End With
Sheets("Tabelle3").Copy before:=Sheets("Tabelle1")
Sheets("Tabelle3 (2)").Visible = True
ActiveSheet.Name = "Tabelle2"
With Worksheets("Tabelle2")
ActiveSheet.Unprotect
Dim lSh As Worksheet
With ThisWorkbook
For Each lSh In .Sheets
If .Sheets(lSh.Name).Range("A1").Value = "1" And lSh.Name  "2" Then
For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
If Cells(i, 4) = "a " Or Cells(i, 4) = "b " Or Cells(i, 4) = "c" Or _
Cells(i, 4) = "d" Or Cells(i, 4) = "e" Or _
Cells(i, 4) = "f" Or Cells(i, 4) = "g" Or _
Cells(i, 4) = "h" Or Cells(i, 4) = "i" Or _
Cells(i, 4) = "j" Or Cells(i, 4) = "k" _
Or Cells(i, 4) = "l" Or Cells(i, 4) = "m" _
Or Cells(i, 4) = "n" Or Cells(i, 4) = "o" _
Or Cells(i, 4) = "p" Or Cells(i, 4) = "q" _
Or Cells(i, 4) = "r" Or Cells(i, 4) = "s" _
Or Cells(i, 4) = "t" Or Cells(i, 4) = "u" _
Or Cells(i, 4) = "v" Or Cells(i, 4) = "w" _
Or Cells(i, 4) = "x" Or Cells(i, 4) = "y" Or Cells(i, 4) = "z" _
Or Cells(i, 4) = "aa" Or Cells(i, 4) = "ab" _
Or Cells(i, 4) = "ac" Or Cells(i, 4) = "ad" _
Or Cells(i, 4) = "ae" Or Cells(i, 4) = "af" _
Or Cells(i, 4) = "ag" Or Cells(i, 4) = "ah" _
Or Cells(i, 4) = "ai" Or Cells(i, 4) = "aj" _
Or Cells(i, 4) = "ak" Or Cells(i, 4) = "al" Then
Rows(i - 1).Copy
Cells(i - 1, 1).EntireRow.Insert
Rows(i - 1).Replace What:="Standardblatt!", Replacement:=lSh.Name & "!", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Rows(i - 1).Copy
Rows(i - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Outline.ShowLevels RowLevels:=1
End If
Next i
Application.CutCopyMode = False
End If
Next
End With
For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
If Cells(i, 4) = "am" Then
Rows(i).EntireRow.Delete
End If
Next i
For i = Cells(Rows.Count, 4).End(xlUp).Row To 1 Step -1
If Cells(i, 4) = "an" Then
ActiveSheet.HPageBreaks.Add before:=Cells(i - 1, 4)
End If
Next i
End With
Range("D3").Value = Date
Worksheets("Tabelle1").Unprotect
Worksheets("Tabelle1").Cells.Replace What:="Standardblatt!", Replacement:="Tabelle2!", _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:= _
False
Worksheets("Tabelle1").EnableOutlining = True
Worksheets("Tabelle1").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, AllowFiltering:=True, userInterfaceOnly:=True
ActiveSheet.Unprotect
Range("A1:ad1").Select
ActiveWindow.Zoom = True
Range("A1").Select
Dim Ende As Integer
Ende = ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row
With ActiveSheet.PageSetup
.PrintArea = "$c$1:$ad$" & Ende
.PrintTitleRows = "$1:$8"
.FitToPagesWide = 1
.FitToPagesTall = False
.Zoom = False
End With
ActiveSheet.EnableOutlining = True
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowFormattingColumns:=True, userInterfaceOnly:=True
Application.Calculation = StBerechnung ' Berechnungsmodus zurück
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub


6
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Optimiterungspotentiale
19.12.2007 09:33:02
ransi
HAllo
Fürs Erste:
Die erste Schleife um das Blatt zu löschen kannst du weglassen.
Sheets("Tabelle2").Delete
reicht wenn es das Blatt gibt.
####
Dieses If cells(I,4) = a or cells(I,4) = b or Konstrukt kannst du so erschlagen:
If Cells(I, 4) Like "[a-z]" Or Cells(I, 4) Like "a" & "[a-i]" Then
Rows(I - 1).Copy
ransi

AW: Optimiterungspotentiale
19.12.2007 09:36:43
Salim
Hallo Ransi,
Danke für dein Feedback.
Gruss
Salim

AW: Optimiterungspotentiale
20.12.2007 12:42:43
Wolli
Hallo Salim, ohne dass ich den Code gelesen habe: Du hast etwas mit ....copy kopiert und woanders eingefügt, der "Kopiermodus" ist aber noch aktiv.
Setze an geeigneter Stelle (sobald Du die Information eingefügt hast) die Zeile "Application.CutCopyMode = False" ein und Deine Probleme sind behoben!
Gruß, Wolli

Anzeige
AW: Optimiterungspotentiale
20.12.2007 13:25:28
Salim
Hallo Wolli,
danke für dein Vorschlag! Funktioniert aber aus meiner Sicht mit diesem Makro nicht, da ungefähr 400 mal kopiert und eingefügt wird. Ich habe zwar am Ende der Schleife CutCopyMode = False drin stehen aber bringt halt vorher nichts. Gibt es eigentlich eine Möglichkeit ohne Copy und Insert zu arbeiten aber mit dem selben Ergebnis?
Gruss
Salim

AW: Optimiterungspotentiale
20.12.2007 20:17:22
Erich
Hallo Salim,
probier mal

Rows(i - 1).Insert
Rows(i).Copy Rows(i - 1)
Rows(i - 1).Replace What:="Standardblatt!", Replacement:=lSh.Name & "!", LookAt _
:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Rows(i - 1).Value = Rows(i - 1).Value
'statt
'       Rows(i - 1).Copy
'       Cells(i - 1, 1).EntireRow.Insert
'       Rows(i - 1).Replace What:="Standardblatt!", Replacement:=lSh.Name & "!", LookAt _
'       :=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
'       ReplaceFormat:=False
'       Rows(i - 1).Copy
'       Rows(i - 1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
'       :=False, Transpose:=False

Application.CutCopyMode = False kannst du dann wohl weglassen (ungestestet).
Rückmeldung wäre nett! - Grüße von Erich aus Kamp-Lintfort

Anzeige
AW: Optimiterungspotentiale
21.12.2007 10:02:46
Salim
Hallo Erich,
herzlichen Dank. Funktioniert super!!!!
Gruss
Salim

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige