Re : archiver et supprimer botton
il ya une erreur quand je l'applique
ActiveSheet.Shapes.Range(Array("ARCHIVE")).Delete voila erreur
Sub ARCH()
Dim Path As String
Dim FileName1 As String
Dim FileName2 As String
Dim wkbSource As Workbook
Dim strChildPath As String
Dim FSO As Scripting.FileSystemObject
Dim strSubFolderName As String
Dim PathA As String
Set FSO = New FileSystemObject
strSubFolderName = ThisWorkbook.Sheets(1).Range("I9")
strChildPath = ThisWorkbook.Sheets(1).Range("N22")
If strSubFolderName = vbNullString Or strChildPath = vbNullString Then
MsgBox "Sub Folder or Child Path Missing", vbCritical
Exit Sub
End If
strSubFolderName = Format(Replace(strSubFolderName, "\", "-"), "mm-yyyy")
CheckAndCreateFolder "C:\inventory\"
Path = "C:\Inventory\" & strSubFolderName & "\"
CheckAndCreateFolder Path
PathA = Path & strChildPath & "\"
CheckAndCreateFolder PathA
FileName1 = ThisWorkbook.Sheets(1).Range("H6")
FileName2 = ThisWorkbook.Sheets(1).Range("N22")
If FileName1 = vbNullString Or FileName2 = vbNullString Then
MsgBox "File Name 1 or File Name 2 is missing ", vbCritical
Exit Sub
End If
Set wkbSource = ThisWorkbook
'wkbSource.SaveCopyAs PathA & FileName1 & "_" & FileName2 & ".xlsm" ', FileFormatvalue = 52
'ActiveWorkbook.Close savechanges:=False
Application.DisplayAlerts = False
wkbSource.Worksheets(1).Copy
ActiveSheet.Shapes.Range(Array("ARCHIVE")).Delete
ActiveWorkbook.SaveAs PathA & FileName1 & "_" & FileName2 & ".xlsx", xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close savechanges:=False
End Sub
Function CheckAndCreateFolder(strFolderName As String)
Dim FSO As FileSystemObject
Set FSO = New FileSystemObject
If Not FSO.FolderExists(strFolderName) Then
FSO.CreateFolder (strFolderName)
End If
End Function