Résolu VBA Importer m onglets de n classeurs dans une nouvelle feuille

  • Auteur de la discussion Hannibal1008
  • Date de début

Hannibal1008

Nouveau membre
Bonsoir,
J'ai besoin de votre aide pour réaliser une macro capable de:
1-Importer tous les onglets visibles de plusieurs classeurs provenant d'un même dossier pour simplifier :) ( sinon éventuellement si possible une boite de dialogue me demandant de sélectionner les classeurs dans différents fichiers)
2-Les onglets et le nombre de lignes sont variables d'un classeur à l'autre, les onglets ont des entêtes identiques mais ne commencent pas forcement à la même ligne (l'idée est de commencer l'importation après l'entête de colonne "affaires" et à partir de "en cours", et de copier les contenus de tous les onglets les uns en dessous des autres après avoir précisé la direction de production).
'Si possible une boite de dialogue qui simplifierait ça (je ne sais pas comment).
3-Supprimer ensuite les lignes vide pour avoir un fichier bien propre, et surtout ne rien modifier aux classeurs sources (aucune demande d'enregistrement ou de messages inutiles).

J'ai un code qui marche bien pour des classeurs simples avec une seule feuille (même configuration sur chaque feuille et les données empilées les unes en dessous des autres sans espace), j'aimerais que vous m'aidiez à l'adapter svp.
Je voudrai mettre en pièce jointe un fichier exemple, mais je ne trouve pas cette option.

Code:
Sub Transferer()
Dim dossier As Object, Fichier As Object
Dim Chemin As String
Dim Derlg As Integer
Dim c As Range

Application.ScreenUpdating = False
Application.DisplayAlerts = True

Derlg = Range("A65536").End(xlUp).Row + 1
Range("A2:N" & Derlg).Clear

Chemin = ThisWorkbook.Path
           FName = Dir(Chemin & "\" & "*.xls")
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)

For Each Fichier In dossier.Files
    
NomFichier = Fichier.Name
If Not Fichier.Name = "Recap.xls" Then

Derlg = Range("A65536").End(xlUp).Row + 1

Workbooks.Open Filename:=Chemin & "/" & NomFichier

On Error Resume Next
        
With Workbooks(NomFichier)
.Sheets("Feuil1").Range("A2:N" & Range("A65536").End(xlUp).Row).Copy ThisWorkbook.Sheets("Feuil1").Range("A" & Derlg)
.Close
End With

End If
Next

End Sub

Merci d'avance pour votre aide :)
 

drul

Obscur pro du hardware
Staff
Salut, ben c'est un excellent début ;)
As-tu fais toi même ce code ?

On ne joint pas de fichier ici pour des raisons de sécurité, par contre les captures d'écran sont les bienvenues.
Si j'ai bien compris il te manque:
- La boucle pour chaque onglet (ici tu ne fais que la feuille1).
- La détermination de début de la plage à copier. (tu entends quoi par "direction de production" ?), le critère de début de èplage c'est quoi (ici tu parles de "affaires" et de "en cours", mais c'est pas claire pour moi, donne un exemple avec une capture d'écran)
- éliminer les lignes vides

Quelle est ton problème pour réaliser ces 3 éléments ?
Le 1 se fait avec une simple boucle "for each"
le 2 peux être réaliser de différentes façon, mais j'ai besoin de plus de précision pour choisir la meilleure voix
le 3 est encore une simple boucle (un gros piège à éviter toutefois)
 

Hannibal1008

Nouveau membre

Merci, il me manque bien les 3 points que tu cites.
Je debute en vba, j'ai trouvé ce code sur internet et l'ai juste un peu modifié. Mais je n'arrive pas à ajouter une boucle et à faire fonctionner le code.
Voici l'image du fichier source (tu peux y voir la "direction de production", "affaire" et "en cours"

celle du fichier de synthèse (c'est pas complet, mais l'idée est de faire quelque chose qui ressemble à ça, avec dans la colonne A le nom de la direction de production):

Bonne journée



 

drul

Obscur pro du hardware
Staff
Pour mettre une image, il faut l'uploader sur un site de partage genre casimage, Tom's ne fait pas hébérgeur d'image ... et je n'ai pas accès à ton C:\ ...
 

Hannibal1008

Nouveau membre
Merci de votre réponse.
Je vous met les liens de deux fichiers sources et le fichier de synthèse.

Edit modération: pas de lien vers des fichiers potentiellement dangeraux pour les aidants ici. C'est interdit par le réglement du forum

Merci encore pour vos réponses.
 

drul

Obscur pro du hardware
Staff
Salut, pas de fichier ici, c'est pourquoi je te demande des captures d'écran pour bien visualiser ton problème.

pour boucler sur toutes les feuilles de chaque workbook, on peut modifier ton code de la manière suivante:
Code:
Sub Transferer()
Dim dossier As Object, Fichier As Object
Dim wb As Workbook
Dim feuille As Worksheet
Dim FeuilleDest As Worksheet
Dim Chemin As String
Dim Derlg As Integer
Dim c As Range
 
Application.ScreenUpdating = False
Application.DisplayAlerts = True
 
Set FeuilleDest = ActiveSheet
 
Derlg = Range("A65536").End(xlUp).Row + 1
Range("A2:N" & Derlg).Clear
 
Chemin = ThisWorkbook.Path
FName = Dir(Chemin & "\" & "*.xls")
Set dossier = CreateObject("Scripting.FileSystemObject").GetFolder(Chemin)
 
    For Each Fichier In dossier.Files
 
       NomFichier = Fichier.Name

       If InStr(1, Fichier.Name, "Recap.xls") = 0 Then
    
           Set wb = Workbooks.Open(Chemin & "/" & NomFichier)
           
           For Each feuille In wb.Sheets
           
               Derlg = FeuilleDest.Range("A65536").End(xlUp).Row + 1
    
               On Error Resume Next
           
               feuille.Range("A2:N" & feuille.Range("A65536").End(xlUp).Row).Copy FeuilleDest.Range("A" & Derlg)
           Next
           wb.Close
       End If
    Next
 
End Sub

Pour le point 2 par contre il faut que tu sois plus précis, je n'arrive pas à comprendre quel est la condition de début de plage.

Pour le point 3, essaye de regarder la fonction "CountA" qui sera très utile ici:

Edit: corriger un ou deux bug dans la macro ... :pt1cable:
 

Hannibal1008

Nouveau membre
Bonsoir Drul, merci beaucoup :)
Voici le lien:
fichier source
Vous devez être connecté pour voir les images.
[/URL][/img]
fichier destination
Vous devez être connecté pour voir les images.
[/URL][/img]

En fait les critères ont un peu changé:
1- la colonne A peut être vide, et le tableau commence à partir de la colonne B, C ou D...
-Serait-il possible que la macro cherche "affaires" dans les 10 prémières colonnes plutôt que seulement dans A? (ça dépassera pas non plus normalement les 20 premières lignes)
-Une fois affaire trouvée, qu'elle copie les lignes non vides à partir de cette colonne jusqu'à la 16 ème colonne après (par exemple si "affaires" est dans A, copier les lignes non vides de A à P; si "affaires" est dans B, copier les lignes non vides de B à Q etc.
2- In n'y a pas toujours "*(1) Affaire neutralisée par l'aléa DP" à la fin des fichiers.
-En fait il faudra s'arrêter dès qu'on tombe sur un truc contenant "ALEAS" ou "aléas" ( un truc comme ça "* ALEAS *" peut être?)
3- La direction de production n'est pas toujours précisée en fait, et des fois c'est "Dir Production", des fois "Dir Prod", des fois rien.
En fait le plus simple sera de chercher "SOCIETE: " comme on a cherché "affaire" mais sur les 10 premières lignes et 10 premières colonnes, et de mettre le nom de la société à la place de la direction de production. (Il faudra tenir compte du fait que le nom de la société peut être dans les cellules à droite de celle qui contient "SOCIETE").
Si on ne trouve pas la société, mettre le nom du classeur et de l'onglet par défaut, suivi de la copie.
4- Enfin pour la copie, copie spéciale ne copier que les valeurs, ne pas tenir compte des liaisons qu'il y'a dans les fichiers sources ou les formules etc. Respecter les formats des colonnes du fichier de destination préalablement préparés.
N'hésite pas à mettre un peu de commentaires dans le code :)
Merci encore d'avance pour vos réponses.
 

drul

Obscur pro du hardware
Staff
Salut, alors ce n'est pas moi qui ferai ton code tu sais ;)

Je te donne des pistes, mais c'est à toi de les mettres en oeuvres selon tes besoins.
Le résultat exact que tu cherches à obtenir est loin d'être clair actuellement (tu veux en faire quoi de dir prod ou de société ?)
Le coup du aléa qui peut être écrit de différente façon c'est loin d'être un cadeau, une rigueur à la saisie facilite grandement la réalisation des macros !

Donc pour la recherche de "AFFAIRES" je te propose ceci:

Code:
Sub trouve()
    Dim maCell As Range
    Set maCell = ActiveSheet.UsedRange.Find("AFFAIRES")
    If Not (maCell Is Nothing) Then
        MsgBox maCell.Row & ":" & maCell.Column
    End If
End Sub

Pour aléa, par contre, il faudra faire plus compliqué ...

Code:
Sub trouveAlea()
Dim maCell As Range
For Each maCell In ActiveSheet.UsedRange
    If LCase(maCell.Value) Like "*al[e,é]a*" Then 'on convertit en minuscule, puis on compare. plus d'info sur like ci-dessous 
        MsgBox "trouvé ! " & maCell.Row & ":" & maCell.Column
    End If
Next
End Sub
L'aide sur l'opérateur "like"


Essaie d'utiliser ceci et reviens avec un code (même non fonctionnel) pour qu'on puisse discuter/corriger de ta solution.
 

Hannibal1008

Nouveau membre
Merci beaucoup Drul,
je suis entièrement d'accord avec toi à propos de la rigueur, les filiales ne respectent pas du tout la maquette.
J'ai essayé avec ce code, mais il ne marche pas.
Code:
Option Explicit

Private moShSynth As Worksheet

Public Sub Synthese()

    Dim sRep As String
    Dim oFSO As FileSystemObject
    Dim oFic As File
    Dim iDerLig As Integer
    Dim iCol As Integer
    sRep = ChoixDossier
    
    If sRep = "" Then
        Exit Sub
    End If
    
    Set oFSO = New FileSystemObject
    Set moShSynth = Worksheets("Synthese")
    
    'RAZ
    iDerLig = moShSynth.Range("B" & Rows.Count).End(xlUp).Row
    If iDerLig >= 8 Then
        moShSynth.Rows("8:" & iDerLig).Delete
    End If
    
    'parcours du répertoire
    For Each oFic In oFSO.GetFolder(sRep).Files
        ImportFichier oFic.Path
    Next oFic
    
    Set oFSO = Nothing
    Set moShSynth = Nothing
    
End Sub

Private Sub ImportFichier(psFichier As String)

    Dim oWB As Workbook
    Dim oSh As Worksheet
    
    Set oWB = Workbooks.Open(psFichier, , True)
    
    For Each oSh In oWB.Worksheets 'parcours des onglets
    
        If oSh.Visible = xlSheetVisible Then
            ImportOnglet oSh
        End If
    Next oSh
    
    oWB.Close False
    Set oWB = Nothing
    
End Sub

Private Sub ImportOnglet(poSh As Worksheet)

    Dim bFin As Boolean
    Dim iLig As Integer
    Const I_MAX As Integer = 20
    Dim iEcr As Integer
    Dim bAffaireTrouve As Boolean 'commence à partir de "AFFAIRES"
    Dim iCol As Integer
    'ligne d'écriture (max colonne B + 1)
    iEcr = moShSynth.Range("B" & Rows.Count).End(xlUp).Row + 2
    
    Application.ScreenUpdating = False
    
    bAffaireTrouve = False
    iLig = 1
    iCol = 1
    bFin = False
    While Not bFin
'        If iLig = 10 Then
'            MsgBox "Ligne n°" & iLig, vbExclamation
'        End If_
        If poSh.Range(Cells(iCol, iLig)).Value = "*(1) Affaire neutralisée par l'aléa DP " Then
            bFin = True
        ElseIf iLig >= I_MAX Then
            iCol = iCol + 1
            bFin = True
        ElseIf UCase(Left(poSh.Range(iCol & iLig).Value, 18)) = "SOCIETE :" Then
            'MsgBox iLig, vbExclamation
            moShSynth.Range(iCol & iEcr).Value = poSh.Range(iCol & iLig).Value
            iLig = iLig + 1
        ElseIf UCase(Left(poSh.Range(iCol & iLig).Value, 18)) = "AFFAIRES" Then
            bAffaireTrouve = True
            iLig = iLig + 2 '2 lignes de titre
        ElseIf bAffaireTrouve Then
            If LigneRemplie(poSh, iLig) Then
                'écrit toutes les lignes non vides
                'copie et colle la ligne
                Dim bout As Integer
                bout = iCol + 16
                poSh.Range(iCol & iLig & "bout" & iLig).Copy
                moShSynth.Range("B" & iEcr).PasteSpecial xlPasteAll
                iEcr = iEcr + 1
            End If
            iLig = iLig + 1
        Else
            iLig = iLig + 1
        End If
    Wend
    
    Application.ScreenUpdating = True
    
End Sub

Private Function LigneRemplie(poSh As Worksheet, piLig As Integer) As Boolean

    Dim iCol As Integer
    Dim bRemplie As Boolean
    
    bRemplie = False
    
    For iCol = 1 To 16 'A à P
        If poSh.Cells(piLig, iCol) <> "" Then
            bRemplie = True
            Exit For
        End If
    Next iCol
    
    LigneRemplie = bRemplie
    
End Function
Merci d'avance pour vos corrections.
 

drul

Obscur pro du hardware
Staff
c'est propre en tous cas ...
dis moi ce qui ne marche pas.
essayes de décomposer, là tu fais tout en même temps, c'est dur à débugger
 

drul

Obscur pro du hardware
Staff
poSh.Range(iCol & iLig & "bout" & iLig).Copy
ça c'est pas bon entous cas ...
poSh.Range(poSh.cells(iLig, iCol), poSh.cells(iLig,bout)).Copy 'me paraît mieux ...
 

Hannibal1008

Nouveau membre
Merci, j'ai éssayé mais toujours pas bon.
Le message d'erreur est: "La methode Range de l'objet worksheet a échoué"
ça beugue à partir de là
Code:
 End If_
        If poSh.Range(Cells(iCol, iLig)).Value = "*(1) Affaire neutralisée par l'aléa DP " Then
            bFin = True
 

drul

Obscur pro du hardware
Staff
Erreur de syntaxe, le code correct est: (attention cells (ROW, COL)
Code:
 End If_
        If poSh.Cells(iLig, iCol).Value = "*(1) Affaire neutralisée par l'aléa DP " Then
            bFin = True

Ensuite ici:

Code:
        ElseIf iLig >= I_MAX Then
            iCol = iCol + 1
            bFin = True
il faut aussi réinitialiser iLig !

Ensuite:
Code:
Range(iCol & iLig)
doit être remplacer partout par:
Code:
Cells(iLig, iCol)

et ici:

Code:
UCase(Left(poSh.Range(iCol & iLig).Value, 18)) = "SOCIETE :"
pourquoi prendre 18 caractères et les comparer à seulement 8 ???
Perso je ferais:
Code:
UCase(poSh.Cells(iLig, iCol).Value) like "SOCIETE :*"

Il y a sûrement d'autres erreurs, mais commence déjà par corriger tous ceci et on verra après ... (reposte ton code en indiquant ou ça ne marche pas le cas échéant)
 

Hannibal1008

Nouveau membre
Bonsoir Drul,
il n'y a plus de bug dans le code, il fonctionne mais ne fait pas du tout ce que je voudrais qu'il fasse.
1-Il ne copie pas toutes les lignes non vides jusqu'à "*al[é, e]as*" mais s'arrête à la première ligne vide.
2-Il ne copie pas non plus les données de tous les onglets visibles (il copie seulement quand "affaires" est dans la colonne A).
Voici le nouveau code:
Code:
Option Explicit

Private moShSynth As Worksheet

Public Sub Synthese()

    Dim sRep As String
    Dim oFSO As FileSystemObject
    Dim oFic As File
    Dim iDerLig As Integer
    Dim iCol As Integer
    sRep = ChoixDossier
    
    If sRep = "" Then
        Exit Sub
    End If
    
    Set oFSO = New FileSystemObject
    Set moShSynth = Worksheets("Synthese")
    
    'RAZ
    iDerLig = moShSynth.Range("B" & Rows.Count).End(xlUp).Row
    If iDerLig >= 8 Then
        moShSynth.Rows("8:" & iDerLig).Delete
    End If
    
    'parcours du répertoire
    For Each oFic In oFSO.GetFolder(sRep).Files
        ImportFichier oFic.Path
    Next oFic
    
    Set oFSO = Nothing
    Set moShSynth = Nothing
    
End Sub

Private Sub ImportFichier(psFichier As String)

    Dim oWB As Workbook
    Dim oSh As Worksheet
    
    Set oWB = Workbooks.Open(psFichier, , True)
    
    For Each oSh In oWB.Worksheets 'parcours des onglets
    
        If oSh.Visible = xlSheetVisible Then
            ImportOnglet oSh
        End If
    Next oSh
    
    oWB.Close False
    Set oWB = Nothing
    
End Sub

Private Sub ImportOnglet(poSh As Worksheet)

    Dim bFin As Boolean
    Dim iLig As Integer
    Const I_MAX As Integer = 20
    Dim iEcr As Integer
    Dim bAffaireTrouve As Boolean 'commence à partir de "AFFAIRES"
    Dim iCol As Integer
    'ligne d'écriture (max colonne B + 1)
    iEcr = moShSynth.Range("B" & Rows.Count).End(xlUp).Row + 2
    
    Application.ScreenUpdating = False
    
    bAffaireTrouve = False
    iLig = 1
    iCol = 1
    bFin = False
    While Not bFin
'        If iLig = 10 Then
'            MsgBox "Ligne n°" & iLig, vbExclamation
'        End If_
        If poSh.Cells(iLig, iCol).Value = "*al[e,é]a*" Then
            bFin = True
        ElseIf iLig >= I_MAX Then
            iCol = iCol + 1
            bFin = True
            iLig = 1
        ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "SOCIETE :*" Then
            'MsgBox iLig, vbExclamation
            moShSynth.Cells(iEcr, iCol).Value = poSh.Cells(iLig, iCol).Value
            iLig = iLig + 1
        ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "AFFAIRES" Then
            bAffaireTrouve = True
            iLig = iLig + 2 '2 lignes de titre
        ElseIf bAffaireTrouve Then
            If LigneRemplie(poSh, iLig) Then
                'écrit toutes les lignes non vides
                'copie et colle la ligne
                Dim bout As Integer
                bout = iCol + 16
                poSh.Range(poSh.Cells(iLig, iCol), poSh.Cells(iLig, bout)).Copy
                moShSynth.Range("B" & iEcr).PasteSpecial xlPasteAll
                iEcr = iEcr + 1
            End If
            iLig = iLig + 1
        Else
            iLig = iLig + 1
        End If
    Wend
    
    Application.ScreenUpdating = True
    
End Sub

Private Function LigneRemplie(poSh As Worksheet, piLig As Integer) As Boolean

    Dim iCol As Integer
    Dim bRemplie As Boolean
    
    bRemplie = False
    
    For iCol = 1 To 16 'A à P
        If poSh.Cells(piLig, iCol) <> "" Then
            bRemplie = True
            Exit For
        End If
    Next iCol
    
    LigneRemplie = bRemplie
    
End Function

En fait comme resultat, ça ne copie que ça
Vous devez être connecté pour voir les images.
[/URL][/img]

Merci encore pour tes réponses
 

drul

Obscur pro du hardware
Staff
je regarde demain (dsl on est décalé, je répond le matin, tu bosses le soir ...)

P.S utilises la balise [code="vb"] ... ton code ... [/code] ça met plein de jolie couleur et rend ton code plus lisible pour moi (et m'évite d'avoir à chaque fois à corriger ton post)
 

drul

Obscur pro du hardware
Staff
re,
alors premier problème:
dès que tu as finit la colonne 1, tu quittes ton while:
Code:
        ElseIf iLig >= I_MAX Then
            iCol = iCol + 1
            bFin = True ' ici ton quitte ton while, donc on ira jamais voir les autres colonnes ...
' J'imagine que ce que tu désires ici est: bFin = bAffaireTrouve 
            iLig = 1
Remarque: ta boucle pourrait être infinie, il serait bon de mettre un J_MAX pour les colonnes, et la tu mets bFin à true.

Ensuite:
Code:
If poSh.Cells(iLig, iCol).Value = "*al[e,é]a*" Then
Attention "=" compare si les 2 strings sont strictement égales ! ici c'est l'opérateur "like" qu'il faut utiliser.

Ensuite deux remarque:
1°) "SOCITETE" risque d'être écrasé lors de la copie, puisque tu n'incrémente pas iEcr ...
2°) ta fonction "ligneRemplie" ne marche qui si "AFFAIRE" est en colonne A ! (elle n'est pas "relative" et verifie donc uniquement les colonnes 1 à 16) ...

Une manière de rendre ta fonction relative:
Code:
Private Function LigneRemplie2(initCell As Range) As Boolean
 
    Dim iCol As Integer
    Dim bRemplie As Boolean
 
    bRemplie = False
 
    For iCol = 0 To 15 '16 colonne depuis initCell (compris)
        If initCell.Offset(0, iCol) <> "" Then
            bRemplie = True
            Exit For
        End If
    Next iCol
 
    LigneRemplie = bRemplie
 
End Function
Que tu appelleras de la manière suivante:
Code:
If LigneRemplie2(poSh.Cells(iLig, iCol)) Then


 

Hannibal1008

Nouveau membre
Bonsoir Drul,
ça y est le code est opérationnel, tout est presque bon sauf que je ne sais pas comment faire pour incrémenter iEcr pour que "SOCIÉTÉ: " ne soit pas écrasée.
Si tu peux me dire comment faire, ce serait parfait.
Un grand merci encore pour tout.
J'ai rencontré un problème qui n'était pas soulevé jusque là, c'est que les filiales mettent "affaires" dans plusieurs cellules des fois (un peu comme des cellules fusionnées, mais juste l'entête), ce qui fait qu'il peut y avoir des colonnes vides entre les trucs, ou pire encore elles peuvent masquer des colonnes (même si c'est uniquement la partie visible qui nous intéresse, ça reste néanmoins un problème).
Je ne sais pas vraiment quoi faire pour arranger ce bordel.
Et même s'il y'avait un code pour que: sur une ligne non vide donnée, on ne copie que les cellules qui contiennent une valeur et qu'on les colle l'une après l'autre dans le fichier de destination, ça ne resoudrait pas le problèmes puisqu'il y'a des fois des cellules(cases) non renseignées dans le tableau.
Si tu as des idées pour moi, je suis vraiment preneur.
Bonne soirée
 

drul

Obscur pro du hardware
Staff
capture d'écran, que je comprenne bien ...
pour societe:
ElseIf UCase(poSh.Cells(iLig, iCol).Value) Like "SOCIETE :*" Then
'MsgBox iLig, vbExclamation
moShSynth.Cells(iEcr, iCol).Value = poSh.Cells(iLig, iCol).Value
iLig = iLig + 1
iEcr=iEcr+1
 
Vous devez vous inscrire ou vous connecter pour répondre ici.
Derniers messages publiés
Statistiques globales
Discussions
730 098
Messages
6 717 065
Membres
1 586 286
Dernier membre
petitangebleu1977
Partager cette page
Haut