Synthétiser des données de plusieurs feuilles sur une feuille

capi16

XLDnaute Nouveau
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".
A partir du fichier, merci de voir comment (de préférence par la méthode des filtres avancées) réaliser ma demande.
Merci
 

Pièces jointes

  • Essai_zombe.xlsx
    97.9 KB · Affichages: 41

Efgé

XLDnaute Barbatruc
Re : Synthétiser des données de plusieurs feuilles sur une feuille

Bonjour capi16,

Par fitre avancé, ce n'est pas mon fort, une proposition tout de même, qui ne prend pas en compte les feuilles masquées :

VB:
Sub test()
Dim i&, Sh As Worksheet, ShDest As Worksheet, Liste$
Liste = ",251125,251132,251134,253110,253111,253115,253116,253210,253216,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

Cordialement
 

zombe

XLDnaute Occasionnel
Re : Synthétiser des données de plusieurs feuilles sur une feuille

Salut Efgé et le forum

Merci pour votre code.
Il fonctionne bien mais quand je l'intègre dans un autre code, il y'a débogage.
Code:
Sub Zomaplus() 'By Mr Zomaplus

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
Le débogage souligne ici
Code:
 For Each Ws2 In ThisWorkbook.Sheets
Merci de m'aider
 

Efgé

XLDnaute Barbatruc
Re : Synthétiser des données de plusieurs feuilles sur une feuille

Re
La ligne
Code:
For Each Ws2 In ThisWorkbook.Sheets
Ne fait pas partie de mon code...
Essai :
Code:
For Each Ws2 In ThisWorkbook.Worksheets

Cordialement
 

Discussions similaires

Statistiques des forums

Discussions
311 716
Messages
2 081 828
Membres
101 823
dernier inscrit
mohamed3s