Inhalt mit Color index 40 Löschen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub Test() Dim InMsgBox As Integer InMsgBox = MsgBox("Wollen Sie die Farbe 40 wirklich löschen.", vbYesNoCancel + _ vbQuestion, "Löschabfrage ?") Select Case InMsgBox Case 6 Dim RaZelle As Range For Each RaZelle In ActiveSheet.UsedRange If RaZelle.Interior.ColorIndex = 40 Then RaZelle.ClearContents End If Next RaZelle Case 7 ' MsgBox "Nein" Case 2 ' MsgBox "Abbrechen" End Select End Sub

Hallo Dennis,
verbundene Zellen machen immer Probleme. Zum Teufel mit dem Microsoftprogrammierer dem das eingefallen ist.
Teste das mal:

Option Explicit

Public Sub Test()
    Dim objCell As Range
    If MsgBox("Wirklich löschen?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
        Application.ScreenUpdating = False
        With Application.FindFormat
            Call .Clear
            .Interior.ColorIndex = 40
        End With
        Set objCell = Cells.Find(What:="*", LookAt:=xlPart, SearchFormat:=True)
        If Not objCell Is Nothing Then
            Do
                If objCell.MergeCells Then
                    Call objCell.MergeArea.ClearContents
                Else
                    Call objCell.ClearContents
                End If
                Set objCell = Cells.Find(What:="*", LookAt:=xlPart, SearchFormat:=True)
            Loop Until objCell Is Nothing
        End If
        Application.ScreenUpdating = True
    End If
End Sub

Gruß
Nepumuk

Hallo Dennis,
das ist nicht normal. Ist es so schneller?

Option Explicit

Public Sub Test()
    Dim objCell As Range
    If MsgBox("Wirklich löschen?", vbQuestion Or vbYesNo, "Abfrage") = vbYes Then
        With Application
            .Calculation = xlCalculationManual
            .EnableEvents = False
            .ScreenUpdating = False
        End With
        With Application.FindFormat
            Call .Clear
            .Interior.ColorIndex = 40
        End With
        Set objCell = Cells.Find(What:="*", LookAt:=xlPart, SearchFormat:=True)
        If Not objCell Is Nothing Then
            Do
                If objCell.MergeCells Then
                    Call objCell.MergeArea.ClearContents
                Else
                    Call objCell.ClearContents
                End If
                Set objCell = Cells.Find(What:="*", LookAt:=xlPart, SearchFormat:=True)
            Loop Until objCell Is Nothing
        End If
        With Application
            .Calculation = xlCalculationAutomatic
            .EnableEvents = True
            .ScreenUpdating = True
        End With
    End If
End Sub

Gruß
Nepumuk

dim Zelle as Range dim Bereich as Range for Each Zelle In ActiveSheet.UsedRange.SpecialCells(xlcelltypeconstants) if Zelle.Interior.ColorIndex = 40 Then if Bereich is Nothing then Set Bereich = Zelle.MergeArea else Set Bereich = Union(Bereich, Zelle.MergeArea) end If end If Next If Not Bereich is Nothing Then Bereich.ClearContents

Beliebteste Forumthreads (12 Monate)

Inhalt mit Color index 40 Löschen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Inhalt mit Color index 40 Löschen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

305 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread