XL 2019 Dupliquer un onglet identique de 200 classeurs dans un seul classeur avec 200 onglets

nicolino

XLDnaute Nouveau
Bonsoir,

Tout est dans le titre (ou presque) :)

Je suis assez novice et c'est mon premier post.

J'aimerai trouver la bonne macro pour réaliser cette tâche très monotone manuellement (j'en suis à une centaine de classeurs et je craque à les ouvrir un à un...) qui consiste à dupliquer un onglet identique nommé "PHOTOS" de plusieurs classeurs "fichier n°1.xlsx" et "fichier n°2.xlsx" dans un seul classeur "Fichier complet.xlsx" avec tous les onglets à la suite mais renommés.

Exemple fichiers en PJ:

  • fichier n°1.xlsx
  • fichier n°2.xlsx
  • Fichier complet.xlsx

J'aimerai copier l'onglet PHOTOS du fichier n°1 et l'onglet PHOTOS du fichier n°2 dans le classeur Fichier complet en renommant les onglets avec le texte présent dans la cellule A2.

fichier n°1.xlsx
1642718108252.png


fichier n°2.xlsx
1642718111384.png



Fichier complet.xlsx

1642718310479.png


1642717939532.png


Un grand merci par avance pour votre aide :)

Nicolas
 

Pièces jointes

  • Fichier complet.xlsx
    14.2 KB · Affichages: 7
  • fichier n°1.xlsx
    12.7 KB · Affichages: 5
  • fichier n°2.xlsx
    12.7 KB · Affichages: 4
Dernière édition:
Solution
Ce n'est plus le même sujet, normalement il faudrait créer une nouvelle discussion.

Mais comme c'est vraiment très classique voici le code pour créer les liens en colonne B :
VB:
Sub Liens()
Dim c As Range, w As Worksheet
Application.ScreenUpdating = False
On Error Resume Next 'si une feuille n'existe pas
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Range("B2:B" & .Rows.Count).Clear 'RAZ
    For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        Set w = Nothing
        Set w = Sheets("Photos du poteau n°" & c)
        .Hyperlinks.Add c(1, 2), "", "'" & w.Name & "'!A1"
    Next
End With
End Sub

job75

XLDnaute Barbatruc
Bonsoir nicolino, bienvenue sur XLD,

Téléchargez les fichiers joints dans le même dossier (le bureau).

Et sur le fichier Fichier complet(1).xlsm cliquez sur le bouton pour exécuter cette macro :
VB:
Sub Consolider()
Dim chemin$, fichier$, w As Worksheet
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---suppression des feuilles PHOTOS---
For Each w In Worksheets
    If UCase(w.Name) Like "PHOTOS*" Then w.Delete
Next
'---copie des fichiers---
While fichier <> ""
    With Workbooks.Open(chemin & fichier)
        Err = 0
        .Sheets("PHOTOS").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        If Err = 0 Then ThisWorkbook.ActiveSheet.Name = "PHOTOS " & Left(.Name, Len(.Name) - 5)
        .Close False
    End With
    fichier = Dir 'fichier suivant
Wend
Sheets(1).Select
End Sub
Avec 200 fichiers à ouvrir et copier la durée d'exécution sera assez longue.

Bonne nuit.
 

Pièces jointes

  • Fichier complet(1).xlsm
    20.8 KB · Affichages: 8
  • fichier n°1.xlsx
    13 KB · Affichages: 7
  • fichier n°2.xlsx
    13 KB · Affichages: 6

nicolino

XLDnaute Nouveau
Bonjour nicolino, le forum,

On remarquera que je n'utilise pas le texte situé en A2 pour nommer les feuilles.

En effet ce texte peut être erroné : sans le mot PHOTOS ou en doublon.

A+

Bonjour @job75 !

Un grand merci pour votre rapide réponse et la macro, c'est super efficace :) !

J'ai réussi à reproduire la macro sur mon fichier de travail mais en effet je n'arrive pas à renommer les onglets comme je le souhaitais, je cherche une solution...

1642760939451.png


En fait dans mes cellules A2, j'ai ce texte : "Photos du poteau n°XXXXX", ce que j'aurai aimé dans le nom de l'onglet.

Si vous avez un tuyau je suis preneur !

Merci

Bien à vous
 

job75

XLDnaute Barbatruc
Je vois qu'il y a un onglet nommé "photos", avec ma macro du post #2 ce n'est pas possible car il est supprimé.

Maintenant si vous voulez absolument nommer l'onglet avec le texte en A2 utilisez :
VB:
Sub Consolider()
Dim chemin$, fichier$, w As Worksheet
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
'---suppression des feuilles PHOTOS---
For Each w In Worksheets
    If UCase(w.Name) Like "PHOTOS*" Then w.Delete
Next
'---copie des fichiers---
While fichier <> ""
    With Workbooks.Open(chemin & fichier)
        .Sheets("PHOTOS").Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
        ThisWorkbook.ActiveSheet.Name = .Sheets("PHOTOS").Range("A2")
        .Close False
    End With
    fichier = Dir 'fichier suivant
Wend
Sheets(1).Select
End Sub
Mais comme je l'ai dit cela peut être source d'erreurs.
 

nicolino

XLDnaute Nouveau
J'ai encore une interrogation mais je ne sais pas si je dois continuer à alimenter ce post ou créer un nouveau sujet ?

Maintenant que j'ai mes 200 onglets, je voudrais ajouter un lien hypertexte dans une colonne de mon tableau général qui pointe vers l'onglet correspondant (en fonction du numéro contenu dans la cellule A) :

Manuellement c'est assez long: clic droit, lien, dans ce document, puis trouver le bon onglet !

1642774201588.png


Je suis preneur d'une nouvelle idée de génie :)

Merci encore
 

job75

XLDnaute Barbatruc
Ce n'est plus le même sujet, normalement il faudrait créer une nouvelle discussion.

Mais comme c'est vraiment très classique voici le code pour créer les liens en colonne B :
VB:
Sub Liens()
Dim c As Range, w As Worksheet
Application.ScreenUpdating = False
On Error Resume Next 'si une feuille n'existe pas
With ActiveSheet 'à adapter
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    .Range("B2:B" & .Rows.Count).Clear 'RAZ
    For Each c In .Range("A2", .Range("A" & .Rows.Count).End(xlUp))
        Set w = Nothing
        Set w = Sheets("Photos du poteau n°" & c)
        .Hyperlinks.Add c(1, 2), "", "'" & w.Name & "'!A1"
    Next
End With
End Sub
 

Discussions similaires

Statistiques des forums

Discussions
311 721
Messages
2 081 927
Membres
101 842
dernier inscrit
seb0390