In onderstaande code kopieer ik mijn worksheet en sla ik deze op in een map afhankelijk van de datum.
Mijn workbook sluit af maar nu blijft de gekopieerde file geopend. Welke code zet ik hierbij om deze ook te sluiten?
Mijn workbook sluit af maar nu blijft de gekopieerde file geopend. Welke code zet ik hierbij om deze ook te sluiten?
Code:
Private Sub CommandButton1_Click()
On Error GoTo GetOut
Dim ws As String, folder As String
Dim Datum1 As String, Datum As String
Dim maand As Integer, Datum2 As String
Dim file As String
Dim wse As Worksheet
ActiveSheet.Protect "", False
ws = Range("A2")
Datum = Range("B6")
folder = ActiveWorkbook.Path & "\Afgenomen audits"
Datum1 = Format(Datum, "mmmm")
Datum2 = Format(Datum, "dd-mm-yyyy")
file = ActiveWorkbook.Path & "\Afgenomen audits" & "" & Datum1
If Dir(file, vbDirectory) = vbNullString Then
MkDir (file)
End If
If WorksheetFunction.CountA(Range("B6")) = 0 Then
MsgBox "Gelieve een datum in te vulllen"
Exit Sub
End If
If WorksheetFunction.CountA(Range("D9")) = 0 Then
MsgBox "Gelieve een naam in te vulllen"
Exit Sub
End If
With Application
.ScreenUpdating = False
On Error GoTo GetOut
Sheets(Array("3rd level")).Copy
On Error GoTo 0
For Each wse In ActiveWorkbook.Worksheets
wse.Cells.Copy
wse.[A1].PasteSpecial Paste:=xlValues
wse.Cells.Hyperlinks.Delete
Application.CutCopyMode = False
wse.Activate
Next wse
ActiveWorkbook.SaveCopyAs Filename:=folder & "" & Datum1 & "" & ws & " " & Datum2 & " " & Cells(9, 4) & ".xls"
MsgBox "Document met succes opgeslagen"
ActiveWorkbook.Close SaveChanges:=False
End With
Application.ScreenUpdating = True
GetOut:
MsgBox Err.Description
End Sub
Laatst bewerkt: