Codekürzung VBA Excel

I

InExplicit

Grünschnabel
Hi leute,

Ich bins mal wieder!

Hab eine bitte an alle die sich in VBA-Excel auskennen - ich hab einen Modul in dem ich mein letztes gepostet problem eingefügt habe und seitdem kopiert und formatiert es sehr langsam. Was bedeutet das Problem muss an Modul2 in der Formatierung liegen.

Was ich nun machen will, ist denn SourceCode so kompakt wie möglich zu gestalten!
Wäre euch über jeden Vorschlag sehr dankbar!
Natürlich werde ich es auch selbst machen und Eure Vorschläge miteinbeziehen und denn fertig gekürtzten Code dann am Ende posten!

Danke schon mal im voraus!

Lg InEx :suspekt:

Code: 
Sub Formatierung()

Range("A1:B1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .ShrinkToFit = False
        .MergeCells = False
    End With
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 14
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleSingle
        .ColorIndex = xlAutomatic
    End With
    
    Selection.Merge
    ActiveCell.FormulaR1C1 = "Ultrasound Defect Report"
    
    
    Tabelle10.Cells.Interior.ColorIndex = 15
    Tabelle10.Rows(2).Interior.ColorIndex = 50
    Tabelle10.Cells(1, 1).Interior.ColorIndex = 4



        Cells.Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With


    Rows("2:2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    
    
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    
    
        Range("A1:B1").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    
    Columns("A:A").EntireColumn.AutoFit
    Columns("B:B").EntireColumn.AutoFit
    Columns("C:C").EntireColumn.AutoFit
    Columns("D:D").EntireColumn.AutoFit
    Columns("E:E").EntireColumn.AutoFit
    Columns("F:F").EntireColumn.AutoFit
    Columns("G:G").EntireColumn.AutoFit
    Columns("H:H").EntireColumn.AutoFit
    Columns("I:I").EntireColumn.AutoFit
    Columns("J:J").EntireColumn.AutoFit
    Columns("K:K").EntireColumn.AutoFit
    Columns("L:L").EntireColumn.AutoFit
    Columns("M:M").EntireColumn.AutoFit
    Columns("N:N").EntireColumn.AutoFit
    Columns("O:O").EntireColumn.AutoFit
    Columns("P:P").EntireColumn.AutoFit
    Columns("Q:Q").EntireColumn.AutoFit
    Columns("R:R").EntireColumn.AutoFit
    Columns("S:S").EntireColumn.AutoFit
    Columns("T:T").EntireColumn.AutoFit
    Columns("U:U").EntireColumn.AutoFit
    Columns("V:V").EntireColumn.AutoFit
    Columns("W:W").EntireColumn.AutoFit
    Columns("X:X").EntireColumn.AutoFit
    


    Cells.Select
    Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
 'Neuer versuch
        
        'kopiert Spalte J nach Z
        
    Columns("J:J").Select
    Selection.Copy
    Columns("Z:Z").Select
    ActiveSheet.Paste
    
        '*kopieren Ende
        

Application.OnKey "{ESC}" 'copyauswahl verlieren
        
Range("J:J") = ("=Y1")                  'J1=Y1 autofill fortlaufend
Columns("J:J").Interior.ColorIndex = 6  'stellt Spaltenfarbe auf Gelb

Range("Z2").Select                      'stellt J1 wieder auf standard formatierung
    Selection.Copy
        Range("J2").Select
        ActiveSheet.Paste
        
Range("J1") = ""                        'stellt J1 inhalt auf leer
Range("J1").Interior.ColorIndex = 15    'stellt J1 wieder normal

            Columns("Z:Z").EntireColumn.Hidden = True   'Versteckt Spalte Z
            Columns("Y:Y").EntireColumn.Hidden = True   'Versteckt Spalte Y

'Neuer Versuch * ENDE
        
        
MsgBox ("Tabellenblatt wurde formatiert! ..." & vbCrLf & vbCrLf & "und" & vbCrLf & vbCrLf & "... nach DefectOpenDate sortiert!!"), vbInformation

Range("A1").Select

End Sub


Sub Prüfung()
    
Dim Suchen As Integer
Dim Weiter As Integer
Dim EndFind As Integer
Dim I As Integer
Range("A1").Select
EndFind = ActiveSheet.Cells(65536, 1).End(xlUp).Row

For I = 1 To EndFind

    Daten = Cells(I, 1).Value
 
 For Each d In Range(Cells(I + 1, 1), Cells(EndFind, 1)) 'Find-Spalte
    If Daten = d Then
        Zelle = d.Row
        Rows(Zelle & ":" & Zelle).Select 'Zeile auswählen
        Selection.Interior.ColorIndex = 3 ' Wenn schon daten vorhanden löschen
        EndFind = EndFind - 1
    End If
  If EndFind < 1 Then EndFind = 1
 Next d
Next I

Range("A1").Select
    
    MsgBox ("Rote Zeilen sind mehrfach eingetragen," & vbCrLf & vbCrLf & "Suchoption: SerialNumber"), vbInformation


End Sub


Sub Prüfung2()
    
Dim Suchen As Integer
Dim Weiter As Integer
Dim EndFind As Integer
Dim I As Integer
Range("C1").Select
EndFind = ActiveSheet.Cells(65536, 3).End(xlUp).Row

For I = 1 To EndFind

    Daten = Cells(I, 3).Value
 
 For Each d In Range(Cells(I + 1, 3), Cells(EndFind, 3)) 'Find-Spalte
    If Daten = d Then
        Zelle = d.Row
        Rows(Zelle & ":" & Zelle).Select 'Zeile auswählen
        Selection.Interior.ColorIndex = 27 ' Wenn schon daten vorhanden markieren
        EndFind = EndFind - 1
    End If
  If EndFind < 1 Then EndFind = 1
 Next d
Next I
    

Range("A1").Select
    
    MsgBox ("Gelbe Zeilen sind mehrfach eingetragen," & vbCrLf & vbCrLf & "Suchoption: SerialNumber & Defect Open Date"), vbInformation

End Sub

//EDIT

So hab denn Code schon mal etwas gekürzt!

Hoffe das von euch auch noch vorschläge bzw. Besserungen kommen!

Code: 
Sub Formatierung()

Range("A1:B1").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    With Selection.Font
        .Name = "Arial"
        .FontStyle = "Bold"
        .Size = 14
        .Underline = xlUnderlineStyleSingle
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    
    
    Selection.Merge
    ActiveCell.FormulaR1C1 = "Ultrasound Defect Report"
    
    
    Tabelle10.Cells.Interior.ColorIndex = 15
    Tabelle10.Rows(2).Interior.ColorIndex = 50
    Tabelle10.Cells(1, 1).Interior.ColorIndex = 4



        Cells.Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .Weight = xlThick
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .Weight = xlMedium
            .ColorIndex = xlAutomatic
        End With
        
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .Weight = xlThin
            .ColorIndex = xlAutomatic
        End With


    Rows("2:2").Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    
    
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .Weight = xlThick
        .ColorIndex = xlAutomatic
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .ColorIndex = xlAutomatic
    End With
    
    
    Columns("A:X").EntireColumn.AutoFit

    Cells.Select
    Selection.Sort Key1:=Range("C3"), Order1:=xlAscending, Header:=xlYes, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
        
 'Neuer versuch
        
        'kopiert Spalte J nach Z
        
    Columns("J:J").Select
    Selection.Copy
    Columns("Z:Z").Select
    ActiveSheet.Paste
    
        '*kopieren Ende
        

Application.OnKey "{ESC}" 'copyauswahl verlieren
        
Range("J:J") = ("=Y1")                  'J1=Y1 autofill fortlaufend
Columns("J:J").Interior.ColorIndex = 6  'stellt Spaltenfarbe auf Gelb

Range("Z2").Select                      'stellt J1 wieder auf standard formatierung
    Selection.Copy
        Range("J2").Select
        ActiveSheet.Paste
        
Range("J1") = ""                        'stellt J1 inhalt auf leer
Range("J1").Interior.ColorIndex = 15    'stellt J1 wieder normal

            Columns("Z:Z").EntireColumn.Hidden = True   'Versteckt Spalte Z
            Columns("Y:Y").EntireColumn.Hidden = True   'Versteckt Spalte Y

'Neuer Versuch * ENDE
        
        
MsgBox ("Tabellenblatt wurde formatiert! ..." & vbCrLf & vbCrLf & "und" & vbCrLf & vbCrLf & "... nach DefectOpenDate sortiert!!"), vbInformation

Range("A1").Select

End Sub


Sub Prüfung()
    
Dim Suchen As Integer
Dim Weiter As Integer
Dim EndFind As Integer
Dim I As Integer
Range("A1").Select
EndFind = ActiveSheet.Cells(65536, 1).End(xlUp).Row

For I = 1 To EndFind

    Daten = Cells(I, 1).Value
 
 For Each d In Range(Cells(I + 1, 1), Cells(EndFind, 1)) 'Find-Spalte
    If Daten = d Then
        Zelle = d.Row
        Rows(Zelle & ":" & Zelle).Select 'Zeile auswählen
        Selection.Interior.ColorIndex = 3 ' Wenn schon daten vorhanden löschen
        EndFind = EndFind - 1
    End If
  If EndFind < 1 Then EndFind = 1
 Next d
Next I

Range("A1").Select
    
    MsgBox ("Rote Zeilen sind mehrfach eingetragen," & vbCrLf & vbCrLf & "Suchoption: SerialNumber"), vbInformation


End Sub


Sub Prüfung2()
    
Dim Suchen As Integer
Dim Weiter As Integer
Dim EndFind As Integer
Dim I As Integer
Range("C1").Select
EndFind = ActiveSheet.Cells(65536, 3).End(xlUp).Row

For I = 1 To EndFind

    Daten = Cells(I, 3).Value
 
 For Each d In Range(Cells(I + 1, 3), Cells(EndFind, 3)) 'Find-Spalte
    If Daten = d Then
        Zelle = d.Row
        Rows(Zelle & ":" & Zelle).Select 'Zeile auswählen
        Selection.Interior.ColorIndex = 27 ' Wenn schon daten vorhanden markieren
        EndFind = EndFind - 1
    End If
  If EndFind < 1 Then EndFind = 1
 Next d
Next I
    

Range("A1").Select
    
    MsgBox ("Gelbe Zeilen sind mehrfach eingetragen," & vbCrLf & vbCrLf & "Suchoption: SerialNumber & Defect Open Date"), vbInformation

End Sub

Danke

GreeZ InEx
 
Hallo InExplicit,

versuche einmal folgendes:

am Anfang Deiner Prozedur:

Application.ScreenUpdating = False

und am Ende:

Application.ScreenUpdating = True

Vermutlich wirst Du staunen.

Grüße
Walter Gutermann
 
hi WaGutSo,

ansich ist deine Idee ja sehr gut! Nur 2 Fragen...
1. Soll ich dies nun am Anfang meines Module2 und am Ende stellen!?

und die 2. und viel wichtigere Frage,

ich hab in tabelle1 ein copy auf sheet stehen! in der sheet_Change Prozedur, da ich sobald in tabelle1.range("A:X") etwas eingetragen oder geändert wird genau das selbe unbearbeitet in tabelle10.range("A:X") steht.

unmittelbar danach kommt module2.formatierung in einsatz

hier der Code aus tabelle1:

Code: 
Private Sub Worksheet_Change(ByVal Target As Range)


Tabelle1.Range("A:X").Copy
    Destination = Tabelle10.Range("A:X").PasteSpecial
    
    
    
    
    Tabelle10.Columns("C:C").EntireColumn.AutoFit

pwdStart:               'Sprungmarke wenn Passwort falsch

    If InputBox("Bitte Paßwort eingeben", "Convert_Passwort") = "gregs" Then
        Worksheets("Cognos_Auswertung_Convert").Visible = True
            Sheets("cognos_auswertung_convert").Select
            
            If MsgBox("Cognos_Auswertung_Convert formatieren?", vbYesNo + vbQuestion, _
                "Frage") = vbYes Then GoTo jaFortfahren Else GoTo NeinFortfahren

jaFortfahren:           'Sprungmarke wenn Messagebox-Formatieren = JA

    Module2.Formatierung
    
NeinFortfahren:         'Sprungmarke wenn Messagebox-Formatieren = NEIN
            

    Else
        Worksheets("cognos_auswertung_convert").Visible = False
         MsgBox ("Passwort falsch" & vbCrLf & vbCrLf & "Access denied"), vbCritical
          GoTo pwdStart 'Sprungbefehl wenn Passwort falsch
    End If


End Sub
 
Hallo InExplicit,,
ich hätte wohl das Wort ‚Prozedur’ nicht verwenden sollen. Der Schalter Application.ScreenUpdating hat keinen Einfluss auf den Programmablauf sondern nur auf die Laufzeit des Programmes. Wenn der Schalter auf ‚False’ steht wird die Bildschirmaktualisierung deaktivieren. Dadurch wird die Laufzeit beschleunigt.
Der Befehl Application.ScreenUpdating = False sollte also vor Formatierungen und dgl. stehen. Application.ScreenUpdating = True steht dann am Ende solcher Aktionen bzw. bevor Du ein Ergebnis sehen möchtest. Das muss nicht in der selben Prozedur sein, sondern kann überall, an geeigneter Stelle, in dem Projekt sein.

Grüße
Walter Gutermann
 
Um antworten zu können musst du eingeloggt sein.

Neue Beiträge

Zurück