Discussion :

[FEADEUR]

Bonjour,

J'ai fais un script qui permet de copier certains onglets d'une feuille excel a destination de la feuille active. Ca marche nickel sauf que j'ai un probleme avec les liens internes qui pointe vers le fichier source après copie...
Exemple : Si mon fichier source contient deux onglets "test" et "test2" avec une cellule de mon onglet "test2" qui est "=test1!A1". Si je copie les onglets avec le script (ca marche si je le fais manuellement), cette formule deviendra "=='C:\MONCHEMIN\[MONFICHIERSOURCE.xlsm]Test1'!A1" dans l'onglet "Test2" copié. Savez-vous comment lui dire de conserver "=test1!A1" ?

Merci d'avance !


Voici le script (Info : ListOfSheetToCopy est une liste dont le même nombre d'élément = nombre d'onglet que contient le fichier excel "source". 1 est la valeur donnée à l'entrée de ListOfSheetToCopy si le numéro de l'onglet est a copier (0 sinon) :

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
Sub SuiteProg2(ListOfSheetToCopy)
    Dim compteur As Integer
    Dim Elmt As Variant
    Dim wbFileA As Workbook
    Dim wbFileB As Workbook
    Dim sh As Worksheet
    Dim shCopAfter As Worksheet
 
    Set wbFileA = Application.Workbooks.Open("Chemin du fichier source")
    Set wbFileB = Application.ThisWorkbook
    ThisWorkbook.Activate
 
    Set shCopAfter = wbFileB.Sheets(wbFileB.Sheets.Count)
 
    compteur = -1
    For Each sh In wbFileA.Sheets
        compteur = compteur + 1
        If ListOfSheetToCopy(compteur) > 0 Then
            sh.Copy After:=shCopAfter
            Set shCopAfter = wbFileB.Sheets(wbFileB.Sheets.Count)
        End If
    Next sh
    wbFileA.Activate
    ActiveWorkbook.Close
End Sub

[NVCfrm]

bonsoir,

l'absence de balises de codes dans ton message rend sa compréhension ardue.
Pour changer les liaisons de classeur il suffit généralement d'appeler la methode ChangeLink de WorkBook. avec en premier paramètre le nom du classeur source, le nom du classeur cible et le type de lien.

Autre chose que je te fais remarquer:
Il est inutile d'affecter l'objet ThisWorkBook à une variable. Cela affecte d'ailleurs la lisibilité.
Pour tes opérations manipulations, tu as rarement besoin besoin de faire des Activate.

Le corps de ta procédure peut se présenter ainsi:

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
 
 
    Set wbFileA = Application.Workbooks.Open("Chemin du fichier source")
    Set shCopAfter = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    compteur = -1
 
    For Each sh In wbFileA.Sheets
        compteur = compteur + 1
        If ListOfSheetToCopy(compteur) > 0 Then
            sh.Copy After:=shCopAfter
            Set shCopAfter = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        End If
    Next sh
 
    Elmt = ThisWorkbook.LinkSources(xlExcelLinks)(1)' ou simplement Elmt = wbFileA.Name
    ThisWorkbook.ChangeLink Elmt, ThisWorkbook.Name, xlExcelLinks
 
    wbFileA.Close

ça doit pouvoir aller avec ça.

[FEADEUR]

Merci beaucoup, ca marche nickel !
Désolé pour les balises, j'essaierai de les intégrer la prochaines fois...

Merci également pour les propositions de contraction du code !

Merci encore !

[FEADEUR]

Bonjour,

Je reviens vers vous car a force d'utiliser ce petit code, je me rends compte que cela ne fonctionnne pas pour les feuilles qui contiennent des cellules protégés en écriture par un mot de passe :

"Run-time error '1004':

You cannot use this command on a protected sheet. To use this command, you mus first unprotect the sheet (Review tab, Changes group, Unprotect sheet button). You may be prompted for a password."

Durant l'execution de la commande
"ThisWorkbook.ChangeLink Elmt, ThisWorkbook.Name, xlExcelLinks".

Du coups, je souhaitais que le code ne copie les liens que s'ils ne sont pas protégés (et non pas 1/déprotéger la feuille, 2/copier les liens, 3/reprotéger comme j'ai pu voir sur certains forum). Cela devrait résoudre le pb car j'ai l'impression qu'Excel ne modifie pas les liens protégés en ajoutant le chemin entier du fichier source...

Pouvez-vous m'éclairez ?

Merci d'avance !

[NVCfrm]

bonsoir,

...
Du coups, je souhaitais que le code ne copie les liens que s'ils ne sont pas protégés (et non pas 1/déprotéger la feuille, 2/copier les liens, 3/reprotéger comme j'ai pu voir sur certains forum)...

il te faudrait alors tester la feuille avant la copie.

Code :

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

1
2
3
If sh.ProtectContents then
sh.Copy
...

toutefois ceci reste un traitement général. Si la feuille est protégée tu ne pourras pas avoir accès à certaines propriétés.

[FEADEUR]

Merci pour cette réponse.

Toutefois, cela ne m'arrange pas vraiment de ne pas copier la feuille si certaines de ses cellules sont protégées...

Ne pourrait-on pas imaginer une itération sur chaque cellule de la feuille lors du changeLink, avec le passage à la cellule suivante si la commande renvoi une erreur (=si elle est protégée) ? Une d'équivalence de "try" du language Python en quelque sorte

J'ai essayé (c'est n'importe quoi et ca marche pas évidement)

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
 
    compteur = -1
    For Each sh In wbFileA.Sheets
        compteur = compteur + 1
        If ListOfSheetToCopy(compteur) > 0 Then
            sh.Copy After:=shCopAfter
            Set shCopAfter = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            If Not sh.ProtectContents Then
                Elmt = shCopAfter.LinkSources(xlExcelLinks)(1) ' ou simplement Elmt = wbFileA.Name
                ThisWorkbook.ChangeLink Elmt, ThisWorkbook.Name, xlExcelLinks
            End If
        End If
    Next sh

Sinon, faute de mieux, on ne pouurait pas copier le contenu de chaque cellule du fichier source dans le nouveau ?
Exemple:

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
 
    compteur = -1
    Set plage = Range("A1:AP112")    
    For Each sh In wbFileA.Sheets
        compteur = compteur + 1
        If ListOfSheetToCopy(compteur) > 0 Then
            sh.Copy After:=shCopAfter
            Set shCopAfter = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            For Each cellule In plage
                If Not cellule.ProtectContents(çamarchepas) Then
                    ActiveCell.Value = wbFileA.cell(ActiveCell.Address).Value
                End If
            Next cellule
        End If
    Next sh

Mais je ne connais pas les commandes (.ProtectContents, ne fonctionne pas) et peut-être que cela prendra trop de temps...

C'est une piste ?

Merci d'avance !

[NVCfrm]

bonsoir,

Pour tester la protection d'une cellule, sur une feuille protégée, ce code devrait aller:

Code :

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

if cellule.AllowEdit then

[FEADEUR]

Merci beaucoup !

Alors, si je mixte tout ça :

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
 
 
    compteur = -1
    For Each sh In wbFileA.Sheets
        compteur = compteur + 1
        If ListOfSheetToCopy(compteur) > 0 Then
            sh.Copy After:=shCopAfter
            Set shCopAfter = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
            If Not sh.ProtectContents Then
                Elmt = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name
                ThisWorkbook.ChangeLink Elmt, ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name, xlExcelLinks
            Else
                Set plage = sh.Range("A1:B2")
                For Each cellule In plage:
                    If cellule.AllowEdit Then
                        cellule.Copy Destination:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Cells(cellule.Name)
                    End If
                Next cellule
            End If
        End If
    Next sh

Mais le code plante sur "cellule.name"... je vois pas, avez-vous idée ?
y a-t-il moyen de faire mieux ?

[NVCfrm]

bonsoir,

Code :

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

1
2
3
4
'à la place de:
...Cells(cellule.Name)
'met:
.range(cellule.address)

[FEADEUR]

Nickel, OK merci beaucoup !

[EngueEngue]

Rien besoin de tester.. Si il ne peut pas il nexte! Plus sâle mais moins d'opérations inutiles

Code :

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

On error Resume Next

[FEADEUR]

Ah oui pas mal aussi... ca supprime des lignes du coups... merci !