mit Intersect klappt es
03.10.2012 09:54:25
Erich
Hi Ina und Sepp,
ja, da geben die SpecialCells auch Bereiche zurück, die gar nicht zum betrachteten Betreich gehören.
In der Mappe https://www.herber.de/bbs/user/81967.xls
werden beim Klick auf SpecCells drei Zellen in Spalte A beschrieben:
- A1 ist der betrachtete Betreich
- A3 sind die SpezialCells(xlCellTypeConstants) davon
- A5 ist der Intersect aus A1 und A3
In der Liste in A3 taucht erst die Zelle A1 auf, beim wiederholten Lauf auch A3 und A5.
SpezialCells(xlCellTypeConstants) kümmert sich also nicht zuverlässig darum, welcher Range davor steht.
loeschen3() sollte jetzt funktionieren, loeschen2() auch. Hier die Codes:
Option Explicit
Sub SpecCells()
Dim strR As String, rngSC As Range, rngIn As Range
strR = "C4:F4,J4:K4,E10:J40"
Cells(1, 1) = strR
Set rngSC = ActiveSheet.Range(strR).specialCells(xlCellTypeConstants)
Cells(3, 1) = rngSC.Address(0, 0)
Set rngIn = Intersect(rngSC, ActiveSheet.Range(strR))
If Not rngIn Is Nothing Then Cells(5, 1) = rngIn.Address(0, 0) Else Cells(5, 1) = ""
End Sub
Sub loeschen3() 'von Sepp Ehrensberger - klappt mit Intersect
Dim rngA As Range, rngL As Range
With ActiveSheet
Set rngA = .Range("C4:F4,J4:K4,E10:J40")
.Unprotect
On Error Resume Next
Set rngL = rngA.specialCells(xlCellTypeConstants)
On Error GoTo 0
If Not rngL Is Nothing Then
Set rngL = Intersect(rngA, rngL)
If Not rngL Is Nothing Then rngL = ""
End If
.Protect
End With
Set rngA = Nothing
Set rngL = Nothing
End Sub
Sub loeschen2() 'von Erich - klappt löscht Werte, keine Formeln
Dim raZelle As Range
For Each raZelle In ActiveSheet.Range("C4:F4,J4:K4,E10:J40")
If Not (IsEmpty(raZelle) Or raZelle.HasFormula) Then
If raZelle.MergeCells Then
If raZelle.Address = raZelle.MergeArea(1).Address Then _
raZelle.MergeArea.ClearContents
Else
raZelle.ClearContents
End If
End If
Next raZelle
End Sub
Rückmeldung wäre nett! - Grüße aus Kamp-Lintfort von Erich und: einen schönen Feiertag!