Werkboek met "Alleen lezen" aanbeveling toch opslaan met dezelfde naam.

[jansbl]

"Alleen lezen" aanbeveling uitschakelen / omzeilen.

Hallo,

Om simpel wijzigingen te kunnen doorvoeren in meerdere werkboeken, gebruik ik een werkblad met onderstaande code:

Sub BoekWijzigen()

    Dim lCount As Long
    Dim wbResults, wbCodeBook As Workbook
    Dim ws As Worksheet
    Dim zoekDir, wijzigString As String
    Dim zoekBlad, zoekCel, vanCel, totCel As Variant
    Dim subDirs, wwgezet As Boolean
    Dim ww As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    
    'On Error Resume Next
    
    Set wbCodeBook = ThisWorkbook
    zoekDir = wbCodeBook.Sheets("Aanpasser").Range("D2").Value
    zoekBlad = wbCodeBook.Sheets("Aanpasser").Range("D4").Value
    zoekCel = wbCodeBook.Sheets("Aanpasser").Range("D5").Value
    vanCel = wbCodeBook.Sheets("Aanpasser").Range("D9").Value
    totCel = wbCodeBook.Sheets("Aanpasser").Range("D10").Value
    wijzigString = wbCodeBook.Sheets("Aanpasser").Range("D11").Value
    If wbCodeBook.Sheets("Aanpasser").Range("F2").Value = "Ja" Then
        subDirs = True
      Else
        subDirs = False
    End If
    ww = wbCodeBook.Sheets("Aanpasser").Range("D13").Value
    
    With Application.FileSearch
        .NewSearch
        .LookIn = zoekDir
        .SearchSubFolders = subDirs
        .FileType = msoFileTypeExcelWorkbooks
        '.Filename = "Book*.xls"
        
            If .Execute > 0 Then
                For lCount = 1 To .FoundFiles.Count
                    Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
                    wbResults.ReadOnlyRecommended = False
'SetAttr wbResults, vbNormal
                    teller = 1
                    For Each ws In wbResults.Sheets
                        If wbResults.Sheets(teller).Range(zoekCel).Value = zoekBlad Then
                            If wbResults.Sheets(teller).ProtectContents = True Then
                                wbResults.Sheets(teller).Unprotect Password:=ww
                                wwgezet = True
                            End If
                            wbResults.Sheets(teller).Range("" & vanCel & ":" & totCel & "").Value = wijzigString
                            If wwgezet = True Then
                                wwgezet = False
                                wbResults.Sheets(teller).Protect Password:=ww
                            End If
                        End If
                        teller = teller + 1
                    Next
                    wbResults.Close SaveChanges:=True
                 Next lCount
            End If
    End With
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    MsgBox "Klaar"
End Sub

Dit werk (bijna) perfect. Ik krijg alleen een probleem als een werkboek is opgeslagen met de " Alleen lezen aanbeveling".
De sheet wordt wel gewijzigd, maar bij het opslaan krijg "Opslaan als".
Ik dacht het probleem met

wbResults.ReadOnlyRecommended = False

te omzeilen, maar dat werkt niet.

Enig idee, hoe ik dit werkend krijg?

m.vr.gr.,
Jans

 

[jansbl]

Bestandje bijgevoegd

Heb maar even het wb bijgevoegd

 

[jansbl]

Heeft nog iemand een idee?

Alvast bedankt.

Jans

 

[jansbl]

Heeft nog iemand een idee?

Alvast bedankt.

Jans

Heb de oplossing gevonden. Werkt prima.
Jans

 

[Ginger]

Jansbl, Spijtig dat niemand op je topic heeft gereageerd, maar hartstikke goed dat je 't zelf hebt weten op te lossen. :thumb:
Wil je voor de 'compleetheid' van deze Topic je oplossing nog met ons delen?

Groet, Leo

 

[jansbl]

Jansbl, Spijtig dat niemand op je topic heeft gereageerd, maar hartstikke goed dat je 't zelf hebt weten op te lossen. :thumb:
Wil je voor de 'compleetheid' van deze Topic je oplossing nog met ons delen?

Groet, Leo

Dank je wel Leo,
Het is natuurlijk zo, dat je zelf wel achter veel dingen komt. Maar iedereen is niet even handig, zodat het wel lang kan duren, voordat je iets hebt (uit-)gevonden. Zelf loop ik tegen de 60 en ben dus meer uit de DOS-tijd.

Voor de 'compleetheid' de complete code nogmaals:

Sub BoekWijzigen()

    Dim lCount As Long
    Dim wbResults, wbCodeBook As Workbook
    Dim ws As Worksheet
    Dim zoekDir, wijzigString As String
    Dim zoekBlad, zoekCel, vanCel, totCel As Variant
    Dim subDirs, wwgezet, gewijzigd As Boolean
    Dim ww As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.EnableEvents = False
    gewijzigd = False
        
    On Error Resume Next
    
    Set wbCodeBook = ThisWorkbook
    zoekDir = wbCodeBook.Sheets("Aanpasser").Range("D2").Value
    zoekBlad = wbCodeBook.Sheets("Aanpasser").Range("D4").Value
    zoekCel = wbCodeBook.Sheets("Aanpasser").Range("D5").Value
    vanCel = wbCodeBook.Sheets("Aanpasser").Range("D9").Value
    totCel = wbCodeBook.Sheets("Aanpasser").Range("D10").Value
    wijzigString = wbCodeBook.Sheets("Aanpasser").Range("D11").Value
    If wbCodeBook.Sheets("Aanpasser").Range("F2").Value = "Ja" Then
        subDirs = True
      Else
        subDirs = False
    End If
    ww = wbCodeBook.Sheets("Aanpasser").Range("D13").Value
    
    With Application.FileSearch
        .NewSearch
        .LookIn = zoekDir
        .SearchSubFolders = subDirs
        .FileType = msoFileTypeExcelWorkbooks
        '.Filename = "Book*.xls"
'TO DO: bovenstaande regel nog aanpaasen
        
            If .Execute > 0 Then
                For lCount = 1 To .FoundFiles.Count
                    Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0, ignorereadonlyrecommended:=True)
                    teller = 1
                    For Each ws In wbResults.Sheets
                        If wbResults.Sheets(teller).Range(zoekCel).Value = zoekBlad Then
                            If wbResults.Sheets(teller).ProtectContents = True Then
                                wbResults.Sheets(teller).Unprotect Password:=ww
                                wwgezet = True
                            End If
                            wbResults.Sheets(teller).Range("" & vanCel & ":" & totCel & "").Value = wijzigString
                            gewijzigd = True
                            If wwgezet = True Then
                                wwgezet = False
                                wbResults.Sheets(teller).Protect Password:=ww
                            End If
                        End If
                        teller = teller + 1
                    Next
                    If gewijzigd = True Then
                        wbResults.SaveAs .FoundFiles(lCount), True
                        gewijzigd = False
                    End If
                    wbResults.Close 'SaveChanges:=True (laatste kan weg)
                 Next lCount
            End If
    End With
    
    On Error GoTo 0
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    MsgBox "Klaar"
End Sub

Het verschil zit in de regel "Set wbResults = Workbooks.Open....enz")
Ook de wijze van opslaan heb ik iets aangepast.

Werkboek is bijgevoegd.

m.vr.gr.,
Jans