Aditionner des données de différents classeurs pour n'en faire qu'un

[doudou48]

Bonjour, après avoir fouiller sur le moteur de recherche je suis tombé sur quelques pistes intéressantes mais jamais tout à fait satisfaisantes.
En effet mon problème, même si plusieurs sujets de discussions l'on partiellement résolu, reste le même.

Je vais essayer de vous expliquer correctement ma situation:

J'ai différents classeurs Excel (533 évolutifs) comportant parfois plusieurs onglets ( rassemblant des listes de matériels)
J'aimerais fusionner l'ensemble des classeurs excels dans un seul et même classeur récapitulatif ( je précise que chaque feuille à la même forme (5 colonnes) mais que la quantité de lignes diffère.)
Pour l'instant, j'arrive à faire ça avec cette macro

Sub regroupe()
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim fic As String ' classeur regroupé
Dim ligne As Long ' ligne écriture
Dim nbc As Integer ' nombre de classeurs
Dim nbf As Integer ' nombre de feuilles
Dim nbl As Integer ' nombre de lignes
Dim c As Integer ' nombre de colonnes
Dim l As Long ' ligne lecture
Dim Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0: nbf = 0 ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
Set Wl = ActiveWorkbook.Sheets(1)
nbl = Wl.UsedRange.Rows.Count
c = Wl.UsedRange.Columns.Count
If ligne > 2 Then l = 2 Else l = 1 ' une seule fois le titre
Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
ligne = ligne + nbl - l + 1
nbf = nbf + 1
ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
fic = Dir
Wend
fin:
MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

Mon problème non résolu est le suivant, je voudrais que le nom du document soit rajouter devant chaque ligne de matériel rajouté sur mon classeur récapitulatif (afin que je puisse filtrer par nom ensuite)

Merci d'avance pour votre aide

ps: la macro dont je vous parle est la 1er que j'utilise, je n'avais auparavant jamais même entendu parlé de "macro", ça fait deux jours que je creuse et je me suis résolu à vous demander un peu de votre temps.

Merci
Edouard Magne

 

[Zon]

Re : Aditionner des données de différents classeurs pour n'en faire qu'un

Salut,

l'instruction resize permettra d' écrire en colonne 6 juste aprés avoir copier les données


pour le nom du document , t'entends nom du fichier
il suffit alors de supprimer le ".xls" car il est stocké dans fic

sinon comment trouvé le nom du document? ,

tu pourras écrire :

Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
with thisworkbook.wf
.cells(ligne,6).resize(ligne + nbl - l + 1)=application.substitute(fic,".xls","")
end with

ligne = ligne + nbl - l + 1

 

[doudou48]

Re : Aditionner des données de différents classeurs pour n'en faire qu'un

tu pourras écrire :

Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
with thisworkbook.wf
.cells(ligne,6).resize(ligne + nbl - l + 1)=application.substitute(fic,".xls","")
end with

ligne = ligne + nbl - l + 1


Salut Zon, 

Merci beaucoup de prendre soin de me répondre, alors j'ai essayer de rajouter dans ma macro
ce que tu m'as indiqué ( voir ci dessus)
Malheureusement quand je lance la macro excel m'indique : 0 feuilles regroupés avec 0 feuilles et o lignes


je te met la copie de la macro avec ta modification voir si tu détecte un problème: (je pense ne pas avoir inséré ton code au bon endroit)

Dim Wl As Worksheet     ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
Set Wf = ThisWorkbook.ActiveSheet         ' variable feuille groupe
Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
With Wf
Cells(ligne, 6).Resize(ligne + nbl - l + 1) = Application.Substitute(fic, ".xls", "")
End With
ligne = ligne + nbl - l + 1
nbc = 0: nbf = 0                ' initialisation variables
ligne = 1
fic = Dir(rep)    ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
    chemin = rep & fic       ' chemin fichiers
        Workbooks.Open chemin, 0  ' ouverture
        Set Wl = ActiveWorkbook.Sheets(1)
        nbl = Wl.UsedRange.Rows.Count
        c = Wl.UsedRange.Columns.Count
        If ligne > 2 Then l = 2 Else l = 1  ' une seule fois le titre
        Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
        ligne = ligne + nbl - l + 1
        nbf = nbf + 1
        ActiveWorkbook.Close SaveChanges:=False   ' Fermeture du classeur
        nbc = nbc + 1
End If
    fic = Dir
Wend
fin:
    MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True
 End Sub

En tout cas merci!

 

[Zon]

Re : Aditionner des données de différents classeurs pour n'en faire qu'un

re,

ici il te manque 1 point (.) et thisworkbook

With Wf
Cells(ligne, 6).Resize(ligne + nbl - l + 1) = Application.Substitute(fic, ".xls", "")
End With


With thisworkbook.Wf
.Cells(ligne, 6).Resize(ligne + nbl - l + 1) = Application.Substitute(fic, ".xls", "")
End With

 

[doudou48]

Re : Aditionner des données de différents classeurs pour n'en faire qu'un

j'ai essayé Zon,

j'ai essayé de voir ce que je devais modifier, mais je ne comprend pas, vraiment.

Pourrais tu me mettre la globalité de la macro corrigée, que je n'ai plus qu'à faire un copié collé, et promis dés que ça marche
j' essaie de comprendre ce qui cloche dans la mienne.

Merci beaucoup, je suis vraiment un bleu!

 

[Zon]

Re : Aditionner des données de différents classeurs pour n'en faire qu'un

Re,

j'en ai profité pour modifier mes numéros de lignes :

Sub regroupe()
Dim chemin As String ' classeur regroupé
Dim rep As String ' répertoire à traiter
Dim fic As String ' classeur regroupé
Dim ligne As Long ' ligne écriture
Dim nbc As Integer ' nombre de classeurs
Dim nbf As Integer ' nombre de feuilles
Dim nbl As Integer ' nombre de lignes
Dim c As Integer ' nombre de colonnes
Dim l As Long ' ligne lecture
Dim Wf As Worksheet ' feuille regroupement
Dim Wl As Worksheet ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
Set Wf = ThisWorkbook.ActiveSheet ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0: nbf = 0 ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls") ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
chemin = rep & fic ' chemin fichiers
Workbooks.Open chemin, 0 ' ouverture
Set Wl = ActiveWorkbook.Sheets(1)
nbl = Wl.UsedRange.Rows.Count
c = Wl.UsedRange.Columns.Count
If ligne > 2 Then l = 2 Else l = 1 ' une seule fois le titre
Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)

  With Wf
    .Cells(ligne + IIf(l = 1, 1, 0), 6).Resize(nbl - IIf(l = 2, 1, 0)) = Application.Substitute(fic, ".xls", "")
  End With
ligne = ligne + nbl - l + 1
nbf = nbf + 1
ActiveWorkbook.Close SaveChanges:=False ' Fermeture du classeur
nbc = nbc + 1
End If
fic = Dir
Wend
fin:
MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub

 

[doudou48]

Re : Aditionner des données de différents classeurs pour n'en faire qu'un

allez j'essaye ça en croisant les doigts que ça marche!

je te dis ça de suite, merci en tout cas

 

[doudou48]

Re : Aditionner des données de différents classeurs pour n'en faire qu'un

Bravo, ça marche parfaitement, vraiment encore merci merci merci, je vais essayer de me plonger un peu la dedans maintenant.

Merci beaucoup, encore et encore