Onderstaande code heeft als doel om de waarde van geselecteerde cellen te kunnen veranderen. Ik werk vanuit vaste rekenmodellen die op kwartaalbasis worden gebruikt. De code moet mij helpen om veranderingen die voor alle rekenmodellen in een portefeuille gelden snel en eenvoudig te kunnen aanpassen.
Nu loop ik tegen het probleem aan dat de gewenste cellen inderdaad worden aangepast, maar dat ik de bestanden handmatig moet opslaan als 'Kopie van XXX'. Ik wil eigenlijk dat de aanpassing opgeslagen wordt onder dezelfde bestandsnaam.
Kunnen jullie even mee kijken? Ik kom er zelf niet uit.
Nu loop ik tegen het probleem aan dat de gewenste cellen inderdaad worden aangepast, maar dat ik de bestanden handmatig moet opslaan als 'Kopie van XXX'. Ik wil eigenlijk dat de aanpassing opgeslagen wordt onder dezelfde bestandsnaam.
Kunnen jullie even mee kijken? Ik kom er zelf niet uit.
Code:
Sub start()
SetWachtwoord
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
.DisplayAlerts = False
.AskToUpdateLinks = False
.EnableEvents = False
End With
Dim coll As New Collection
Dim bstnd As Variant
Dim bstndsnaam As String, bestand As String, PAD As String
Set shtMacro = ThisWorkbook.Sheets("Macro")
PAD = shtMacro.[C2].Value
If Right(PAD, 1) <> "\" Then PAD = PAD & "\"
'Zoek eerste bestandsnaam
If shtMacro.[D2].Value = "xlsm" Then bestand = Dir(PAD & "*.xlsm")
If shtMacro.[D2].Value = "xlsx" Then bestand = Dir(PAD & "*.xlsx")
If shtMacro.[D2].Value = "xlsb" Then bestand = Dir(PAD & "*.xlsb")
If shtMacro.[D2].Value = "xls" Then bestand = Dir(PAD & "*.xls")
'Voeg alle bestanden uit de directory toe aan collectie
Do While bestand <> ""
If bestand <> "." And bestand <> ".." Then coll.Add bestand
bestand = Dir
Loop
'Vervang de formules in elk bestand
For Each bstnd In coll
bstndsnaam = PAD & bstnd
ZoekEnVervang bstndsnaam
Next bstnd
MsgBox "Macro is voltooid."
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
.DisplayAlerts = True
.AskToUpdateLinks = True
.EnableEvents = True
End With
End Sub
Private Sub SetWachtwoord()
'Wachtwoord uitlezen en opslaan in variabele
Wachtwoord = Sheets("Macro").OLEObjects("WachtwoordTextBox").Object.Text
'Wachtwoord direct uit textbox verwijderen zodat deze niet te achterhalen is na eventueel opslaan
Sheets("Macro").OLEObjects("WachtwoordTextBox").Object.Text = ""
End Sub
Sub ZoekEnVervang(bestandsnaam As String)
Dim i As Byte
Dim wbkRekenmodel As Workbook
Dim shtCurrent As Worksheet
Dim StatusVergrendeling As Boolean
Dim targetSheet As String, targetCell As String, strReplace As String
Set wbkRekenmodel = Workbooks.Open(bestandsnaam)
For i = 1 To 100
If shtMacro.Cells(4, i + 6).Value <> vbNullString Then
targetSheet = shtMacro.Cells(2, i + 6).Value
targetCell = shtMacro.Cells(3, i + 6).Value
strReplace = shtMacro.Cells(4, i + 6).Value
Set shtCurrent = wbkRekenmodel.Sheets(targetSheet)
StatusVergrendeling = ControleerVergrendeling(shtCurrent, targetCell)
If StatusVergrendeling = True Then
OntgrendelWerkblad shtCurrent
shtCurrent.Range(targetCell).Formula = strReplace
VergrendelWerkblad shtCurrent
Else
shtCurrent.Range(targetCell).Formula = strReplace
End If
End If
Next
wbkRekenmodel.Close SaveChanges:=True
Set wbkRekenmodel = Nothing
End Sub
