Hallo,
Ik ben al een paar dagen aan het stoeien met een macro maar dit wil me niet lukken zoals ik het graag wil hebben.
Een van mijn tabbladen (Test) haald zijn info doormiddel van een =INDEX formule de gegevens uit het Tab Masterfile, dit werkt.
De tab Test is beveiligd voor aanpassingen en heeft dus een wachtwoord.
De bedoeling is dat de macro een nieuwe sheet maakt waar de links uit verwijderd zijn en oplslaat op een in de macro aangegeven locatie met als bestandsnaam verwezen naar een van de cellen maar de nieuwe sheet moet wel beveiligt zijn met het wachtwoord die ook in de tab Test staat.
In de tab Test staan ook een aantal aanvink opties, deze moeten na het opslaan ook gewoon blijven bestaan in de nieuwe sheet.
De bestaande file met het tab Test en tab Masterfile moet ongeweizigt open blijven, dit i.v.m. meerdere opdracht om een nieuwe sheet op te slaan als......
Alvast bedankt voor de hulp.
VP19
Hier onde de macro die ik tot nu toe gemaakt heb, maar hiermee zijn in de nieuwe file de formules nog aanwezig:
Sub savesheet2()
Dim newName As String
Dim nm As Name
Dim ws As Worksheet
Dim WorkbookLinks As Variant
Dim wb As Workbook
Dim i As Long
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("VJ WD ALK")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs Filename:="C:\RMA\RMA_" & CStr(Range("C7").Value) & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
Ik ben al een paar dagen aan het stoeien met een macro maar dit wil me niet lukken zoals ik het graag wil hebben.
Een van mijn tabbladen (Test) haald zijn info doormiddel van een =INDEX formule de gegevens uit het Tab Masterfile, dit werkt.
De tab Test is beveiligd voor aanpassingen en heeft dus een wachtwoord.
De bedoeling is dat de macro een nieuwe sheet maakt waar de links uit verwijderd zijn en oplslaat op een in de macro aangegeven locatie met als bestandsnaam verwezen naar een van de cellen maar de nieuwe sheet moet wel beveiligt zijn met het wachtwoord die ook in de tab Test staat.
In de tab Test staan ook een aantal aanvink opties, deze moeten na het opslaan ook gewoon blijven bestaan in de nieuwe sheet.
De bestaande file met het tab Test en tab Masterfile moet ongeweizigt open blijven, dit i.v.m. meerdere opdracht om een nieuwe sheet op te slaan als......
Alvast bedankt voor de hulp.
VP19
Hier onde de macro die ik tot nu toe gemaakt heb, maar hiermee zijn in de nieuwe file de formules nog aanwezig:
Sub savesheet2()
Dim newName As String
Dim nm As Name
Dim ws As Worksheet
Dim WorkbookLinks As Variant
Dim wb As Workbook
Dim i As Long
Set wb = ActiveWorkbook
With Application
.ScreenUpdating = False
' Copy specific sheets
' *SET THE SHEET NAMES TO COPY BELOW*
' Array("Sheet Name", "Another sheet name", "And Another"))
' Sheet names go inside quotes, seperated by commas
On Error GoTo ErrCatcher
Sheets(Array("VJ WD ALK")).Copy
On Error GoTo 0
' Paste sheets as values
' Remove External Links, Hperlinks and hard-code formulas
' Make sure A1 is selected on all sheets
For Each ws In ActiveWorkbook.Worksheets
ws.Cells.Copy
ws.[A1].PasteSpecial Paste:=xlValues
ws.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
Cells(1, 1).Select
ws.Activate
Next ws
Cells(1, 1).Select
' Remove named ranges
For Each nm In ActiveWorkbook.Names
nm.Delete
Next nm
' Save it with the NewName and in the same directory as original
ActiveWorkbook.SaveCopyAs Filename:="C:\RMA\RMA_" & CStr(Range("C7").Value) & ".xls"
ActiveWorkbook.Close SaveChanges:=False
.ScreenUpdating = True
End With
Exit Sub
ErrCatcher:
MsgBox "Specified sheets do not exist within this workbook"
End Sub
Laatst bewerkt:
