Créer une synthèse à partir de plusieurs feuilles

Salut le forum

J'ai un classeur contenant plusieurs feuilles.

Je souhaite pouvoir copier sur chaque feuille les lignes ou il y'a dans la colonne B les rubriques suivantes:251125, 251132, 251134, 253110, 253111, 253115, 253116, 253210, 253216 et 253900.

Les éléments copier devront être collés sur la feuille "SOURCE".

Merci pour vos contributions

Bonjour,

Tu n'es pas nouveau.

Merci de joindre un fichier à ta demande.

Cdlt.

Salut jean eric

le voici et je m'excuse.

60essai-zombe.xlsx (97.90 Ko)

Re,

A tester.

ALT F11 pour ouvrir l'éditeur VBE.

Cdlt.

123essai-zombe.xlsm (116.02 Ko)

Salut Jean-Eric

Merci pour votre code.

Il fonctionne bien mais quand je l'intègre dans le code si dessous, il y'a débogage dans ici

For Each Ws2 In ThisWorkbook.Sheets

Merci de m'aider

Sub Zoaplus() 'By Mr Zoaplus

Dim Curcalc As XlCalculation
Dim Ws, Ws2 As Worksheet
Dim Chemin As String, Fichier As String

Application.ScreenUpdating = False
Curcalc = Application.Calculation
Application.Calculation = xlCalculationManual

'Définit le répertoire contenant les fichiers
'On Error GoTo std_errhandler

If Sheets("Menu").Range("B7").Value = "" Then
    Chemin = Browseforfolder()
    Sheets("Menu").Range("B7") = Chemin
Else
    Chemin = Sheets("Menu").Range("B7").Value

End If

If Chemin = "" Then Exit Sub
'Boucle sur tous les fichiers rep du répertoire.
Fichier = Dir(Chemin & "\*.rep")

If Fichier = "" Then MsgBox "Aucun fichier de type .rep dans le répertoire sélectionné"

Do While Len(Fichier) > 0
    'Debug.Print Chemin & Fichier
    Application.StatusBar = "Traitement en cours : " & Fichier

    'On vérifie qu'il n'y ait pas de feuille déjà ayant pour nom le même que celui que l'on veut lui donner
    For Each Ws2 In ThisWorkbook.Sheets
        If Ws2.Name = Mid(Fichier, 10, 5) Then
            MsgBox ("Une feuille existe déjà avec pour nom : " & Ws2.Name & vbCrLf & "Merci de bien vouloir la supprimer ou la renommer")
            Exit Sub
        End If
    Next Ws2

    Set Ws = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    Ws.Name = Mid(Fichier, 10, 5)
    'Contient l'ensemble des opérations à effectuer sur le fichier spécifié
    Call Execution(Chemin & "\" & Fichier, Ws)

    Fichier = Dir()
Loop
Set Ws = Nothing
Set Ws2 = Nothing

Sheets("Menu").Select

Application.Calculation = Curcalc
Application.ScreenUpdating = True
Application.StatusBar = False
Exit Sub

std_errhandler:
MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description

Application.Calculation = Curcalc
Application.ScreenUpdating = True
End Sub

Sub Execution(repertoire_source As String, ByVal Cible As Worksheet)

Dim Max_ligne As Long
Dim last_source_line As Long

Dim B, Str As String
Dim Lignes_a_suppr As Collection
Dim L As Variant
Dim i&, Sh As Worksheet, ShDest As Worksheet, Liste$

'Import du fichier
Call copie(Cible, repertoire_source)
'Split en colonnes
Call Split(Cible)

Set source = Sheets("Source")
'Suppression des colonnes B,E,F,I,J,K
Cible.Columns("k:k").Delete Shift:=xlToLeft
Cible.Columns("j:j").Delete Shift:=xlToLeft
Cible.Columns("i:i").Delete Shift:=xlToLeft
Cible.Columns("f:f").Delete Shift:=xlToLeft
Cible.Columns("e:e").Delete Shift:=xlToLeft
Cible.Columns("b:b").Delete Shift:=xlToLeft

'Suppression des lignes pour lesquelles la cellule B est de longueur inférieure à 6
'Les lignes sont d'abord stockées dans une collection, afin de ne pas perturber la boucle
'Puis tous les membres de la collection sont supprimés
Max_ligne = Cible.UsedRange.Rows.Count
Set Lignes_a_suppr = New Collection

For i = 1 To Max_ligne
    Str = Cible.Cells(i, 2).Value
    Str = Replace(Str, " ", "")

    If Len(Str) < 6 Or Str = "------" Then 'la condition 6 tirets n'est pas dans le cahier des charges mais elle m'a paru évidente
        Lignes_a_suppr.Add Cible.Cells(i, 2).EntireRow
    End If
Next i
For Each L In Lignes_a_suppr
    L.Delete
Next L

Set Lignes_a_suppr = Nothing

'Insertion d'une ligne
Cible.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove

'Titres des colonnes
Cible.Cells(1, 1).Formula = "Code Agence"
Cible.Cells(1, 2).Formula = "RC"
Cible.Cells(1, 3).Formula = "Libellé"
Cible.Cells(1, 4).Formula = "Montant"
Cible.Cells(1, 5).Formula = "Nbre"

'Inscription du nom de la feuille en colonne A si b non vide, ou b rempli de blancs
For i = 2 To Max_ligne
    If Replace(Cible.Cells(i, 2).Value, " ", "") <> "" Then
        Cible.Cells(i, 1).Value = Cible.Name
    End If
Next i

'Suppression des .00 et des virgules

Cible.Range("D:E").Replace What:=".00", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

Cible.Range("D:E").Replace What:=",", Replacement:="", LookAt:=xlPart, _
    SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
    ReplaceFormat:=False

'Copie des lignes correspondant à certains critères

Liste = ",202212,202213,202217,202218,202221,202223,202224,202225,202229,203102,203104,203105,203106,203107,203108,203109,203112,203113,203114,203116,203118,203119,204102,204106,204108,204109,204110,204115,251120,251121,251122,251123,251125,251130,251131,251132,251133,251134,251135,251140,251170,251171,251172,251173,251174,251175,251195,252101,252102,252111,252112,253110,253111,253115,253116,253118,253210,253216,253310,253900,"
Set ShDest = Sheets("SOURCE")
Application.ScreenUpdating = False
ShDest.UsedRange.ClearContents
For Each Sh In Worksheets
    If Sh.Name <> ShDest.Name And Sh.Visible = True Then
        For i = 1 To Sh.Cells(Sh.Rows.Count, 1).End(3).Row
            If InStr(Liste, "," & Sh.Cells(i, 2) & ",") > 0 Then
                Sh.Cells(i, 1).Resize(, 5).Copy ShDest.Cells(ShDest.Rows.Count, 1).End(3)(2)
            End If
        Next i
    End If
Next Sh
End Sub

Re,

Quel est le rapport entre la question posée, la réponse apportée et cette nouvelle question?

Cdlt.

Salut Jean-Eric

Merci pour l'intérêt que vous avez accordé à mon sujet.

En lieu et place de la fusion de votre code avec le mien j'ai préféré appelé votre code à la suite du mien et ca marche.

Rechercher des sujets similaires à "creer synthese partir feuilles"