Formatierung / Verschieben per VBA ?

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Selma,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub Format_Selma()
Dim lngR As Long, lngL As Long

On Error GoTo ErrExit
GMS

lngL = Application.Max(Cells(Rows.Count, 1).End(xlUp).Row, _
    Cells(Rows.Count, 3).End(xlUp).Row, _
    Cells(Rows.Count, 3).End(xlUp).Row)

Range("A1:C" & lngL).ClearFormats

For lngR = 1 To lngL

    If Cells(lngR, 2) = "Conf Name" Then

        Range(Cells(lngR, 1), Cells(lngR, 3)).Interior.ColorIndex = 15
        Range(Cells(lngR, 1), Cells(lngR, 3)).Font.Bold = True

    ElseIf Cells(lngR, 1) <> "" And Left(Cells(lngR, 1), 1) <> "-" And Left(Cells(lngR, 1), 1) <> ">" Then

        Cells(lngR, 3) = Cells(lngR, 1)
        Cells(lngR, 1).ClearContents

    ElseIf Left(Cells(lngR, 1), 3) = ">>>" Then

        Range(Cells(lngR, 1), Cells(lngR, 3)).Interior.ColorIndex = 37
        Range(Cells(lngR, 1), Cells(lngR, 3)).Font.Bold = True

    End If

Next

Range("A:C").Columns.AutoFit

ErrExit:
GMS True

End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    .Calculation = IIf(Modus, -4105, -4135)
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Sub Makro1() Dim Zelle As Range Application.ScreenUpdating = False '--- Überschriften färben --- With Columns("A:C") .FormatConditions.Delete .FormatConditions.Add Type:=xlExpression, Formula1:="=ZS2=""Conf Name""" .FormatConditions(1).Font.Bold = True .FormatConditions(1).Interior.ColorIndex = 15 .FormatConditions.Add Type:=xlExpression, Formula1:="=LINKS(ZS1;3)="">>>""" .FormatConditions(2).Font.Bold = True .FormatConditions(2).Interior.ColorIndex = 37 End With '--- Zellen verschieben ------- Columns(4).Insert With Range("D1:D" & Cells(65536, 1).End(xlUp).Row) .FormulaR1C1 = "=IF(OR(RC1="""",LEFT(RC1,1)=""-"",LEFT(RC1,1)="">""),0,TRUE)" For Each Zelle In .SpecialCells(xlCellTypeFormulas, 4) Zelle.Offset(0, -3).Cut Destination:=Zelle.Offset(0, -1) Next Application.CutCopyMode = False End With Columns(4).Delete Application.ScreenUpdating = True End Sub

Hi
ja, ganz sicher ;-)
ich hab nur inkonsequenterweise dann doch wieder ne Schleife eingebaut, damit ich per Cut/Paste auch alle eventuell vorrhandenen Formatierungen mit verschiebe.
wenn man darauf verzichtet und sich auf die Zellinhalte beschränkt, braucht man auch die Schleife nicht mehr:


Sub Makro2()
Dim Zelle As Range
Application.ScreenUpdating = False
'--- Zellen verschieben -------
Columns(4).Insert
Range("D1:D" & Cells(65536, 1).End(xlUp).Row).FormulaR1C1 = "=IF(OR(RC1="""",LEFT(RC1,1)=""- _
"",LEFT(RC1,1)="">""),0,TRUE)"
With Columns(4).SpecialCells(xlCellTypeFormulas, 4)
.Offset(0, -1).FormulaR1C1 = "=RC1"
Columns(3).Formula = Columns(3).Value
.Offset(0, -3).ClearContents
End With
Columns(4).Delete
'--- Überschriften färben ---
With Columns("A:C")
.FormatConditions.Delete
.FormatConditions.Add Type:=xlExpression, Formula1:="=ZS2=""Conf Name"""
.FormatConditions(1).Font.Bold = True
.FormatConditions(1).Interior.ColorIndex = 15
.FormatConditions.Add Type:=xlExpression, Formula1:="=LINKS(ZS1;3)="">>>"""
.FormatConditions(2).Font.Bold = True
.FormatConditions(2).Interior.ColorIndex = 37
End With
Application.ScreenUpdating = True
End Sub

mit diesem Makro sieht bei mir im Performance-Vergleich (12000 Zeilen) so aus:


Mein Makro alt: 18,5 sec
dein Makro    :  1,6 sec
mein Makro neu:  0,25 sec

Gruß, Daniel

Möchte man eine Arbeitsmappe zu speichern, die mehr als 2'050 Zeilen mit Zellen enthält, welche _ eine bedingte Formatierung verwenden, so erscheint die Fehlermeldung "Excel konnte nicht alle Daten und Formatierungen, die Sie dem Dokument hinzugefügt haben speichern." In der englischen Ausgabe von Microsoft Excel lautet die Fehlermeldung "Excel could not save all the data and formatting you recently added to ." (Anmerkung des Autors: Ich hätte gerne den Fehlermeldungsdialog hier abgebildet. Trotz intensiven Bemühungen ist es mir bis heute jedoch nicht gelungen, die Fehlermeldung zu erzeugen.) Wenn mehrere Zellen die gleiche bedingte Formatierung besitzen, d.h. eine identische Bedingungsregel und Formatierung, so können praktisch unbegrenzt viele Zellen mit bedingter Formatierung verwendet werden, ohne dass beim Speichern der Arbeitsmappe die oben erwähnte Fehlermeldung auftritt. Es ist beispielsweise möglich, den Zellbereich A1:J500 eines Tabellenblattes (= 5'000 Zellen) mit einer identischen bedingten Formatierung zu belegen. Die in der folgenden Abbildung dargestellte bedingte Formatierung kann somit problemlos allen 5'000 Zellen zugewiesen werden.

Beliebteste Forumthreads (12 Monate)

Formatierung / Verschieben per VBA ?

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread