Boucle sur les onglets

N

Nonno

XLDnaute Nouveau
Bonjour à tous,

J'ai crée une macro qui me permet d'ouvrir un dossier cible, ouvrir les fichiers excels les uns après les autres et copier coller les données dans des onglets déjà pré établi d'un autre fichier excel. Cependant, il m'arrive parfois d'ajouter de nouveaux fichiers excels dans mon dossier cible sans rajouter d'onglet dans mon fichier excel. Je voudrais donc, par le biais d'une macro automatiser cette action. Càd : lorsqu'il ouvre un fichier excel et qu'il ne reconnait pas le nom de l'onglet comme l'un des noms appartenant à mon fichier excel, il crée l'onglet automatiquement en copiant sa feuille.

Je ne sais pas si j'ai été assez claire...
Merci d'avance pour votre aide

Cdt
Nono
Répo
 
Trier par date Trier par votes
pierrejean

pierrejean

XLDnaute Barbatruc
Re : Boucle sur les onglets

Bonjour Nonno

Une petite fonction qui permet de savoir si une feuille existe

Code: 
Function exist(feuille As String, fichier As String) As Boolean
exist = True
On Error Resume Next
   Set x = Workbooks(fichier).Sheets(feuille)
   If Err.Number <> 0 Then exist = False
On Error GoTo 0
End Function
 
Vote positif 0 Vote négatif
N

Nonno

XLDnaute Nouveau
Re : Boucle sur les onglets

Merci beaucoup Pierre Jean !
A la ligne : Set x = Workbooks(fichier).Sheets(feuille)
Je dois écrire le nom de chaque feuille ?

Ceci est mon code initial :
Code: 
Sub Bouton1_Cliquer()
    Dim FichierMacro As String
    Dim Chemin As String
    Dim DossierDB As String
    Dim FichierDB As String

    FichierMacro = ActiveWorkbook.Name
    Chemin = ActiveWorkbook.Path

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    DossierDB = Sheets("Macro").Range("A2")
    If DossierDB <> "" Then
        FichierDB = Dir(Chemin & "\" & DossierDB & "\SX*.xls")
        Do Until FichierDB = ""
            Workbooks.Open (Chemin & "\" & DossierDB & "\" & FichierDB), UpdateLinks:=False

            Windows(FichierMacro).Activate
            Sheets(Left(FichierDB, Len(FichierDB) - 4)).Select
            Rows("7:7").Select
            Range(Selection, Selection.End(xlDown)).ClearContents
            
            Workbooks(FichierDB).Activate
            Rows("7:1000").Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveSheet.Paste

            Workbooks(FichierDB).Activate
            ActiveWorkbook.Close True
            Application.Wait (Now + TimeValue("00:00:01"))
            FichierDB = Dir
        Loop
    End If

    Sheets("Macro").Select
    ActiveCell.Offset(1, 0).Select

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

    MsgBox ("La compilation est terminée")

End Sub

Merci beaucoup

Nono
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re : Boucle sur les onglets

Re

A tester:

Code: 
Sub Bouton1_Cliquer()
    Dim FichierMacro As String
    Dim Chemin As String
    Dim DossierDB As String
    Dim FichierDB As String


    FichierMacro = ActiveWorkbook.Name
    Chemin = ActiveWorkbook.Path


    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    DossierDB = Sheets("Macro").Range("A2")
    If DossierDB <> "" Then
        FichierDB = Dir(Chemin & "\" & DossierDB & "\SX*.xls")
        Do Until FichierDB = ""
            Workbooks.Open (Chemin & "\" & DossierDB & "\" & FichierDB), UpdateLinks:=False
            
             If Not exist(Left(FichierDB, Len(FichierDB) - 4), FichierDB) Then
                FichierMacro.Sheets.Add.Name = Left(FichierDB, Len(FichierDB) - 4)
            End If


            Windows(FichierMacro).Activate
            Sheets(Left(FichierDB, Len(FichierDB) - 4)).Select
            Rows("7:7").Select
            Range(Selection, Selection.End(xlDown)).ClearContents
                       
            Workbooks(FichierDB).Activate
            Rows("7:1000").Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveSheet.Paste


            Workbooks(FichierDB).Activate
            ActiveWorkbook.Close True
            Application.Wait (Now + TimeValue("00:00:01"))
            FichierDB = Dir
        Loop
    End If


    Sheets("Macro").Select
    ActiveCell.Offset(1, 0).Select


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


    MsgBox ("La compilation est terminée")


End Sub
Function exist(feuille As String, fichier As String) As Boolean
exist = True
On Error Resume Next
   Set x = Workbooks(fichier).Sheets(feuille)
   If Err.Number <> 0 Then exist = False
On Error GoTo 0
End Function
 
Vote positif 0 Vote négatif
N

Nonno

XLDnaute Nouveau
Re : Boucle sur les onglets

Merci beaucoup !!!

Par contre j'ai un message d'erreur à cette partie :
Code: 
  If Not exist(Left(FichierDB, Len(FichierDB) - 4), FichierDB) Then
                FichierMacro.Sheets.Add.Name = Left(FichierDB, Len(FichierDB) - 4)
            End If

C'est le FicierMacro qui ne marche pas je ne comprends pas pourquoi....
 
Vote positif 0 Vote négatif
N

Nonno

XLDnaute Nouveau
Re : Boucle sur les onglets

Merci beaucoup le code a l'air de mieux fonctionner cependant il y a un bug au tout dernier fichier excel qu'il ouvre il me met " impossible de renommer une feuille comme une autre feuille " or il n'y avait pas à renommer seulement à copier coller les valeurs : effectuer cette tâche :
Code: 
  Windows(FichierMacro).Activate
            Sheets(Left(FichierDB, Len(FichierDB) - 4)).Select
            Rows("7:7").Select
            Range(Selection, Selection.End(xlDown)).ClearContents
                       
            Workbooks(FichierDB).Activate
            Rows("7:1000").Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveSheet.Paste
 
Vote positif 0 Vote négatif
N

Nonno

XLDnaute Nouveau
Re : Boucle sur les onglets

J'ai modifié un peu le code mais ca ne marche toujours pas ca bug au niveau
Code: 
Workbooks(FichierDB).Activate
ca me met que l'indice n'appartient pas à la s

Voici mon code (désolée pour la longueur...) :
Code: 
Sub Bouton1_Cliquer()
    Dim FichierMacro As String
    Dim Chemin As String
    Dim DossierDB As String
    Dim FichierDB As String


    FichierMacro = ActiveWorkbook.Name
    Chemin = ActiveWorkbook.Path


    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    DossierDB = Sheets("Macro").Range("A2")
    If DossierDB <> "" Then
        FichierDB = Dir(Chemin & "\" & DossierDB & "\SX*.xls")
        Do Until FichierDB = ""
            Workbooks.Open (Chemin & "\" & DossierDB & "\" & FichierDB), UpdateLinks:=False

            Windows(FichierMacro).Activate
            Sheets(Left(FichierDB, Len(FichierDB) - 4)).Select
            Rows("7:7").Select
            Range(Selection, Selection.End(xlDown)).ClearContents
                       
            Workbooks(FichierDB).Activate
            Rows("7:1000").Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveSheet.Paste


            Workbooks(FichierDB).Activate
            ActiveWorkbook.Close True
            Application.Wait (Now + TimeValue("00:00:01"))
            FichierDB = Dir
            
            If Not exist(Left(FichierDB, Len(FichierDB) - 4), FichierDB) Then
            Workbooks(FichierDB).Activate
            Cells.Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveWindow.ScrollWorkbookTabs Position:=xlLast
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Paste
            ActiveWindow.DisplayGridlines = False
            ActiveWindow.Zoom = 85
            Application.CutCopyMode = False
            With Workbooks(FichierDB).ActiveSheet
            NomOnglet = .Name
            Windows(FichierMacro).Activate
            ActiveSheet.Name = NomOnglet
            End With
            'Workbooks(FichierMacro).Sheets.Add.Name = Left(FichierDB, Len(FichierDB) - 4)
            End If
        Loop
    End If


    Sheets("Macro").Select
    ActiveCell.Offset(1, 0).Select


    Application.ScreenUpdating = True
    Application.DisplayAlerts = True


    MsgBox ("La compilation est terminée")


End Sub
Function exist(feuille As String, fichier As String) As Boolean
exist = True
On Error Resume Next
   Set x = Workbooks(fichier).Sheets(feuille)
   If Err.Number <> 0 Then exist = False
On Error GoTo 0
End Function

Encore un immense merci pour votre aide
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re : Boucle sur les onglets

Re

Es-tu sur de cette ligne

Do Until FichierDB = ""

Ce ne serait pas plutot

Do Until FichierDB <> ""

Par ailleurs je crois que ceci serait plus judicieux:

If Not exist(Left(FichierDB, Len(FichierDB) - 4), FichierMacro) Then
Workbooks(FichierMacro).Sheets.Add.Name = Left(FichierDB, Len(FichierDB) - 4)
End If
 
Vote positif 0 Vote négatif
N

Nonno

XLDnaute Nouveau
Re : Boucle sur les onglets

Bonjour,

Lorsque je mets Do Until FichierDB <> "" ma macro va direct à End If et ne fais rien. Donc je pense plutôt que c'est Do Until FichierDB = ""

J'ai inséré ton code au mien mais ca bug lorsqu'il rencontre un fichier excel qui n'existait pas auparavant dans les onglets.
Voici le code :
Code: 
            Workbooks(FichierDB).Activate
            ActiveWorkbook.Close True
            Application.Wait (Now + TimeValue("00:00:01"))
            FichierDB = Dir
            
            If Not exist(Left(FichierDB, Len(FichierDB) - 4), FichierMacro) Then
            Workbooks(FichierMacro).Sheets.Add.Name = Left(FichierDB, Len(FichierDB) - 4)
            Cells.Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveWindow.ScrollWorkbookTabs Position:=xlLast
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Paste
            ActiveWindow.DisplayGridlines = False
            ActiveWindow.Zoom = 85
            Application.CutCopyMode = False
            With Workbooks(FichierDB).ActiveSheet
            NomOnglet = .Name
            Windows(FichierMacro).Activate
            ActiveSheet.Name = NomOnglet
            End With
            End If
        Loop
    End If

Ca bug au niveau de la ligne : Windows(FichierMacro).Activate. Il me dise que "l'indice n'appartient pas à la sélection" ....

Merci
 
Vote positif 0 Vote négatif
N

Nonno

XLDnaute Nouveau
Re : Boucle sur les onglets

Je viens de changer par Workbooks(FichierMacro).Activate du coup ca n' pas bugué. En revanche, pour le dernier fichier il bloque à : Workbooks(FichierMacro).Activate et ca m'écrit "argument ou appel de procédure incorrect". Je ne comprends pas...
 
Vote positif 0 Vote négatif
pierrejean

pierrejean

XLDnaute Barbatruc
Re : Boucle sur les onglets

Re

Teste ceci

Code: 
Sub Bouton1_Cliquer()
    Dim FichierMacro As String
    Dim Chemin As String
    Dim DossierDB As String
    Dim FichierDB As String




    FichierMacro = ActiveWorkbook.Name
    Chemin = ActiveWorkbook.Path




    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    DossierDB = Sheets("Macro").Range("A2")
    If DossierDB <> "" Then
        FichierDB = Dir(Chemin & "\" & DossierDB & "\SX*.xls")
        Do Until FichierDB = ""
            Workbooks.Open (Chemin & "\" & DossierDB & "\" & FichierDB), UpdateLinks:=False
            
             If Not exist(Left(FichierDB, Len(FichierDB) - 4), FichierMacro) Then
                FichierMacro.Sheets.Add.Name = Left(FichierDB, Len(FichierDB) - 4)
            End If




           Workbooks(FichierMacro).Activate
            Sheets(Left(FichierDB, Len(FichierDB) - 4)).Select
            Rows("7:7").Select
            Range(Selection, Selection.End(xlDown)).ClearContents
                       
            Workbooks(FichierDB).Activate
            Rows("7:1000").Select
            Selection.Copy
            Windows(FichierMacro).Activate
            ActiveSheet.Paste




            Workbooks(FichierDB).Activate
            ActiveWorkbook.Close True
            Application.Wait (Now + TimeValue("00:00:01"))
            FichierDB = Dir
        Loop
    End If




    Sheets("Macro").Select
    ActiveCell.Offset(1, 0).Select




    Application.ScreenUpdating = True
    Application.DisplayAlerts = True




    MsgBox ("La compilation est terminée")




End Sub
 
Vote positif 0 Vote négatif

Discussions similaires

C
  • Question
XL 2021 Excel facturation avec BD clients (modèle utilisable joint) - liste déroulante =INDIRECT sur classeur séparé
Réponses
12
Affichages
433
Calizarine
C
Moi69
  • Résolu(e)
Power Query un tableau via pls onglets n'ayant pas les mêmes colonnes
2
Réponses
21
Affichages
867
Moi69
Moi69
D
  • Question
Microsoft 365 Cas réel - avec problème complexe sur de la prevision de match en evitant les doublons
Réponses
1
Affichages
353
Dock91
D
C
  • Question
Microsoft 365 Copier des données d'un fichier excel sur un fichier word
Réponses
0
Affichages
766
ChristianJ
C
G
  • Question
Power Query Regrouper les donnees de differents onglets excel de differents fichiers dans un seul fichier excel
Réponses
8
Affichages
904
guazzini
G
A
  • Question
Microsoft 365 Copie VBA d'un tableau présent et identique sur 12 onglets dans un autre onglet dont seules les lignes complétées sont copiées
Réponses
4
Affichages
455
AlexiaC
A
E
  • Question
Microsoft 365 Fichier Excel partagé sur réseau avec utilisateurs & droits
Réponses
2
Affichages
835
e01547
E
Simbaa
  • Question
Microsoft 365 Création d'un fichier entier par rapport à des entrées via UserForm
Réponses
1
Affichages
388
job75
job75
M
  • Question
XL 2016 Erreur d'execution '52': Nom ou numéro de fichier incorrect
Réponses
4
Affichages
598
macseb
M
F
  • Question
Microsoft 365 copie de données colonne dans des nouveaux onglets
Réponses
5
Affichages
854
FCMLE44
F

Membres actuellement en ligne

4 membres et 52 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 493
Messages
2 088 956
Membres
103 990
dernier inscrit
lamiadebz