Re : copie onglet dans nouveau classeur
Salut
désolé pour le retard, je ne pensais plus à ton post.
voici un exemple
j'ai abandonné les cases à cocher pour un double clic sur les cellules, elles passent alors en gras rouge, plus simple à gérer que des cases
un clic sur le bouton copie les feuilles, pour le nom du classeur on ne peut le définir qu'à l'enregistrement donc je lance un enregistrement, tu peux prédéfinir le chemin en l'ajoutant soit dans la cellule E13 soit dans la proc en l'ajoutant à la ligne
Nom_Classeur_Temp = Range(Nom_Classeur).Value & ".xls"
qui deviendrait ainsi
Nom_Classeur_Temp = cheminàutiliser & Range(Nom_Classeur).Value & ".xls"
voila le code utilisé, la liste des feuilles se met à jour à l'activation de la feuille
tu peux modifier les constantes
Const Plage_Ref As String = "D18" ' définit le début de la plage des noms de feuilles
Const Nom_Classeur As String = "E13" 'définit le nom de classeur à utiliser
Cordialement, A+
Option Explicit
Const Plage_Ref As String = "D18"
Const Nom_Classeur As String = "E13"
Dim Compteur As Long, Compteur2 As Long
Private Sub Worksheet_Activate()
'initialisation
With Range(Plage_Ref & ":" & Range(Plage_Ref).Offset(65536 - Range(Plage_Ref).Row, 0).End(xlUp).Address)
.Font.ColorIndex = xlAutomatic
.Font.Bold = False
.ClearContents
End With
Compteur2 = 0
For Compteur = 1 To Worksheets.Count
''''activer les deux lignes pour ne pas afficher dans la liste des feuilles la feuille contenant la liste
'If Not (Worksheets(Compteur).Name = ActiveSheet.Name) Then
Range(Plage_Ref).Offset(Compteur2, 0).Value = Worksheets(Compteur).Name
Compteur2 = Compteur2 + 1
'End If
Next Compteur
End Sub
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range(Plage_Ref & ":" & Range(Plage_Ref).Offset(65536 - Range(Plage_Ref).Row, 0).End(xlUp).Address)) Is Nothing Then
Else
With Target
If .Font.ColorIndex = 3 And .Font.Bold = True Then
.Font.ColorIndex = xlAutomatic
.Font.Bold = False
Else
.Font.ColorIndex = 3
.Font.Bold = True
End If
End With
End If
Cancel = True
End Sub
Private Sub CommandButton1_Click()
Dim Nom_Feuil As Range, Noms_Feuilles() As String, Nom_Classeur_Temp As String
Dim Test_Fichier As Integer, Titre_Box As String, Classeur_en_cours As Workbook
Compteur = 0
For Each Nom_Feuil In Range(Plage_Ref & ":" & Range(Plage_Ref).Offset(65536 - Range(Plage_Ref).Row, 0).End(xlUp).Address)
If Nom_Feuil.Font.ColorIndex = 3 And Nom_Feuil.Font.Bold = True Then
Compteur = Compteur + 1
ReDim Preserve Noms_Feuilles(1 To Compteur)
Noms_Feuilles(Compteur) = Nom_Feuil.Value
End If
Next Nom_Feuil
If Compteur > 0 Then
Nom_Classeur_Temp = Range(Nom_Classeur).Value & ".xls"
ThisWorkbook.Sheets(Noms_Feuilles).Copy
'paramètres d'enregistrement du fichier
Titre_Box = "Enregistrement du fichier"
Do
Test_Fichier = 0
Nom_Classeur_Temp = Application.GetSaveAsFilename(Nom_Classeur_Temp, FileFilter:="Fichiers Excel (*.Xls),*.Xls", Title:=Titre_Box)
If Not (Dir$(Nom_Classeur_Temp, vbNormal) = "") Then
Test_Fichier = MsgBox(LCase(Nom_Classeur_Temp) & " existe déja" & Chr(10) & "en date du " & DateValue(FileDateTime(Nom_Classeur_Temp)) & Chr(10) & "voulez vous l'écraser ?", vbYesNo + vbQuestion)
If Not (Test_Fichier = 7) Then
For Each Classeur_en_cours In Application.Workbooks
If StrComp(Classeur_en_cours.FullName, Nom_Classeur_Temp, 1) = 0 Then
MsgBox LCase(Nom_Classeur_Temp) & " est ouvert, ce nom ne peut être utilisé", vbOKOnly + vbCritical
Test_Fichier = 7
Exit For
End If
Next Classeur_en_cours
End If
End If
If Test_Fichier = 7 Then Titre_Box = "Redéfinissez le nom d'enregistrement"
If Nom_Classeur_Temp = "Faux" Then MsgBox "Fichier non enregistré !", vbOKOnly + vbExclamation: Sheets(1).Select: Exit Sub
Loop While Test_Fichier = 7
'sélection de la première feuille
Sheets(1).Select
'enregistrement
ActiveWorkbook.SaveAs Filename:=Nom_Classeur_Temp, FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End If
End Sub
