bestimmte farbige Zellen entsperren

Guten Morgen liebe VBA-Profis
Gerne hätte ich ein Makro, bei welchem ich ein File öffnen kann, und es dann in diesem File alle Zellen mit der Farbe in Zelle B9 des Ursprungfiles abgleicht, und die Zellen welche die gleiche Farbe im neu geöffneten FIle haben, entsperren.
Das Öffnen klappt, das aufrufen der einzelnen Tabs klapt,
aber die gleichfarbigen Zellen zu entsperren, das klappt nicht. Ich vermute, dass der Fehler im fett markierten Bereich liegen müsste.
Seht ihr den Fehler?
Um Hilfe wäre ich sehr froh.
Pascale


Sub unlockcellsbycolor()
Dim colorIndex As Long
Dim color As Long
Dim WS_Count As Integer
Dim I As Integer
Dim xRg As Range
Dim FileToOpen As Variant
Dim OpenBook As Workbook
colorIndex = ThisWorkbook.Worksheets("Start").Range("B9").Interior.color
FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range",     _
FileFilter:="Excel Files (*.xls*),*xls*")
If FileToOpen  False Then
Set OpenBook = Application.Workbooks.Open(FileToOpen)
WS_Count = OpenBook.Worksheets.Count
For I = 1 To WS_Count
Application.ScreenUpdating = False
For Each xRg In ActiveSheet.UsedRange.Cells
        color = xRg.Interior.color
If (color = colorIndex) Then
xRg.Locked = False
Else
xRg.Locked = True
End If
Next xRg
Application.ScreenUpdating = True
Next I
ActiveSheet.Select
MsgBox "Alle Zellen mit der Zellenfarbe wie in B9 wurden entsperrt", vbInformation, "Zellen  _
entsperrt"
End If
End Sub

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Pascale,
teste mal:

Option Explicit

Public Sub unlockcellsbycolor()

    Dim lngColor As Long
    Dim strFirstAddress As String
    Dim objWorksheet As Worksheet
    Dim objcell As Range
    Dim FileToOpen As Variant
    Dim OpenBook As Workbook

    lngColor = ThisWorkbook.Worksheets("Start").Range("B9").Interior.Color

    FileToOpen = Application.GetOpenFilename(Title:="Browse for your File & Import Range", _
        FileFilter:="Excel Files (*.xls*),*xls*")

    If FileToOpen <> False Then

        Set OpenBook = Workbooks.Open(FileToOpen)

        With Application.FindFormat
            Call .Clear
            .Interior.Color = lngColor
        End With

        For Each objWorksheet In OpenBook.Worksheets

            objWorksheet.UsedRange.Locked = True

            Set objcell = objWorksheet.UsedRange.Find(What:="*", _
                LookAt:=xlWhole, SearchFormat:=True)

            If Not objcell Is Nothing Then

                strFirstAddress = objcell.Address

                Do

                    objcell.Locked = False

                    Set objcell = objWorksheet.UsedRange.Find(What:="*", _
                        After:=objcell, LookAt:=xlWhole, SearchFormat:=True)

                Loop Until objcell.Address = strFirstAddress
            End If

        Next objWorksheet

        MsgBox "Alle Zellen mit der Zellenfarbe wie in B9 " & _
            "wurden entsperrt", vbInformation, "Zellen entsperrt"

    End If
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

bestimmte farbige Zellen entsperren

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

233 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

bestimmte farbige Zellen entsperren

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

233 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread