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
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.