Discussion :

[fnroux]

Bonsoir,

j'aimerais réaliser différentes opérations à partir d'un classeur excel comprenant de nombreux onglets. Je vais vous décrire dans l'ordre les différentes actions que j'aimerais pouvoir faire en automatique via une macro.

1 - Choix des onglets à copier
2 - Copier les onglets choisis
3 - Les coller dans un nouveau fichier qui s'enregistrera en auto avec pour seuls onglets ceux selectionnés et se refermera (le nom du fichier est le nom du premier onglet selectionné) --> fichiers à enregistrer dans un dossier spécifique du bureau

Et j'aimerais pouvoir répéter l'opération en choisissant d'autres onglets par la suite et donc relancer la macro pour au final extraire dans différents fichiers les onglets qui m'intéressent.

Si vous avez compris, c'est déjà une prouesse et si vous avez une solution c'est encore plus énorme!!!

Merci pour votre aide.

[nchal]

salut,

dans un module

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub fnroux()
 
Dim les_onglets() As String
Dim les_feuilles() As Worksheet
Dim ws As Worksheet
Dim taille As Integer
taille = 0
UserForm.Show
 
For i = 0 To UserForm.List_onglets.ListCount - 1
    If UserForm.List_onglets.Selected(i) = True Then
        For Each ws In ThisWorkbook.Worksheets
            If ws.Name = UserForm.List_onglets.List(i) Then
                ReDim les_feuilles(taille)
                Set les_feuilles(taille) = ws
                taille = taille + 1
            End If
        Next
    End If
Next i
 
For j = 0 To UBound(les_feuilles)
 
    MsgBox les_feuilles(j).Name
 
Next j
 
End Sub

dans un usf avec un bouton et une listbox renommée

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
Private Sub CommandButton1_Click()
 
Dim choisi As Boolean
choisi = False
For i = 0 To Me.List_onglets.ListCount - 1
    If Me.List_onglets.Selected(i) = True Then
        choisi = True
    End If
Next i
 
If choisi = True Then Me.Hide Else MsgBox "Veuillez choisir au moins 1 onglets"
 
End Sub
 
Private Sub UserForm_Initialize()
 
Dim ws As Worksheet
 
Me.List_onglets.MultiSelect = fmMultiSelectMulti
 
For Each ws In ThisWorkbook.Worksheets
 
    Me.List_onglets.AddItem ws.Name
 
Next
 
End Sub

mais j'ai une erreur sur

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
For j = 0 To UBound(les_feuilles)
 
    MsgBox les_feuilles(j).Name
 
Next j

mais je ne sais pas pourquoi. Si un pro des tableaux peut m'éclairer. Ainsi je pourrais continuer.
Je ne suis pas familier au tableau dynamique mais je n'ai honnetement aucune idée de pourquoi sa plante (Erreur d'éxécution 91, variable d'objet ou variable de bloc with non défini)

[fnroux]

j'ai pas trop compris l'histoire du TCD... ? pourquoi il y aurait besoin d'un TCD dans ce cas?

merci en tout cas d'avoir planché sur mon sujet

[fring]

Bonjour,

teste ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub test()
Dim x As Byte, Wsh As Worksheet
Dim Rep As String, Nom As String
 
Rep = "C:\Temp\" '<-- répertoire de sauvegarde
 
Application.ScreenUpdating = False
For Each Wsh In ActiveWindow.SelectedSheets
    x = x + 1
    Select Case x
        Case 1: Wsh.Copy: Nom = Wsh.Name & ".xls"
        Case Else: Wsh.Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
    End Select
Next
ActiveWorkbook.SaveAs Rep & Nom
ActiveWorkbook.Close
Application.ScreenUpdating = True
 
End Sub

[fring]

Bonjour,

merci pour ton code, cela fonctionne très bien. Le seul point est que dans mes onglets il y a beaucoup de liens vers d'autres fichiers et j'aimerais que lors de la copie des onglets on ne voit que les valeurs dans le nouveau fichier (avec le même format biensûr).

Pourrais-tu m'indiquer si cela est possible en modifiant un peu ton code.

Merci d'avance.

Merci de continuer à poser les questions dans le fil de cette discussion et pas en MP afin que d'autres intervenants puissent apporter leurs solutions éventuelles.

Ceci devrait faire l'affaire

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
Sub test()
Dim x As Byte, Wsh As Worksheet
Dim Rep As String, Nom As String
Dim Hpk As Hyperlink
 
Rep = "C:\Temp\" '<-- répertoire de sauvegarde
 
Application.ScreenUpdating = False
For Each Wsh In ActiveWindow.SelectedSheets
    x = x + 1
    Select Case x
        Case 1: Wsh.Copy: Nom = Wsh.Name & ".xls"
        Case Else: Wsh.Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
    End Select
Next
 
With ActiveWorkbook
    For x = 1 To .Sheets.Count
        For Each Hpk In Sheets(x).Hyperlinks
            Hpk.Delete
        Next
    Next
    .SaveAs Rep & Nom
    .Close
End With
Application.ScreenUpdating = True
 
End Sub

[fnroux]

J'ai essayé avec ton nouveau code mais dans les cases il y a toujours le chemin du fichier source qui est indiqué.

J'aimerais juste avoir les valeurs... dans ces cases et non le renvoi d'une valeur d'un autre fichier.

Comme cela n'importe qui peut ouvrir le fichier et lire les valeurs sans avoir besoin des autres fichiers.

Merci encore pour votre aide.

En fait je m'était mal exprimé lorsque je parlais de lien, ce ne sont pas des liens hypertexte mais des renvois de valeur d'autres fichiers (dans la case on voit le chemin du fichier).... sorry!

[fring]

En fait je m'était mal exprimé lorsque je parlais de lien

Non c'est moi qui avais mal compris

Essaie ceci :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
Sub test()
Dim x As Byte, Wsh As Worksheet
Dim Rep As String, Nom As String
Dim Hpk As Hyperlink
 
Rep = "C:\Temp\" '<-- répertoire de sauvegarde
 
Application.ScreenUpdating = False
For Each Wsh In ActiveWindow.SelectedSheets
    x = x + 1
    Select Case x
        Case 1: Wsh.Copy: Nom = Wsh.Name & ".xls"
        Case Else: Wsh.Copy After:=ActiveWorkbook.Sheets(Sheets.Count)
    End Select
Next
 
With ActiveWorkbook
    For x = 1 To .Sheets.Count
        With Sheets(x).UsedRange
            Set Cel = .Find(what:=".xls]", LookIn:=xlFormulas)
            If Not Cel Is Nothing Then
                Do
                    Cel.Value = Cel.Value
                    Set Cel = .FindNext(After:=Cel)
                Loop While Not Cel Is Nothing
            End If
        End With
    Next
    .SaveAs Rep & Nom
    .Close
End With
Application.ScreenUpdating = True
 
End Sub