Consolidation selon 4 critères

Bonjour à tous

J'ai un classeur avec 6 onglets A.B.C.D.E.F ET 1 onglet RECAP, il s'agit de copier les 6 onglets colonne A à E et X lignes et de les coller dans la RECAP.

mais il y à 4 critères (1) la date du jour en D1 feuil RECAP (2) le choix de l'EQ A, B ou AB en E1 feuil RECAP (3) coller selon la mise en forme des 6 onglets (4) le classeur est partagé

Le VBA je suis novice

Merci

Plutot delicat d'aider

Bonjour

Le classeur est en mode partage

Merci

Donc après quelques recherches pour le partage, voici un essai.

• module Partage qui contient 2 macros: 1 pour arrêter le partage(Arret), 1 autre pour le remettre(Demarre)=>passer en commentaire pour vérifier le reste de la macro et éviter mes paramètres de partage
• module Trier avec la macro Tri: avec boucles et conditions, elle fait le boulot et appelle les macro du module Partage

edit

bonjour

Si le classeur est partagé dans l'onglet RECAP lorsque on appui sur trie tout s'efface et après un 2 appui c'est le bouton qui part

dans l'onglet RECAP tableau de droite ce que la macro doit fait

Moi je voulais si il y avait autre chose que mon code que j'ai actuellement mais il ne fonctionne pas en mode partage

Dont voici les codes pour le partage et départage (quelque difference) que j'ai trouvé dans different forum

et pour le transfert

pourquoi que mes macro fonctionne en mode partage ex pour envoi mail

le problème est le partage car il y 7 utilisateurs et ca risque d'être une source de problème

Merci pour l'aide

Sub Départage()
'
' Mode SHARED "OFF" à l'ouverture
If ActiveWorkbook.MultiUserEditing Then
 Application.DisplayAlerts = False ' Pas de message d'erreur
 ActiveWorkbook.ExclusiveAccess ' Accès exclusif activé !
 Application.DisplayAlerts = True
End If
End Sub
Sub Partage()

'Sauvegarde en réactivant le partage !
If Not ActiveWorkbook.MultiUserEditing Then
 Application.DisplayAlerts = False
 ActiveWorkbook.SaveAs Filename:=ActiveWorkbook.FullName, accessMode:=xlShared
 Application.DisplayAlerts = True
End If
End Sub

Option Explicit
Private Dat As Date, EQ As String

Sub ConsolidationA()
 Dat = Feuil21.[H1].Value
 EQ = Feuil21.[I1].Value
 Feuil21.[2:60000].Delete
 Prendre Worksheets("JOURBRIN1")
 Prendre Worksheets("JOURUMECA")
 Prendre Worksheets("JOURBRIN2")
 Prendre Worksheets("JOURMECAPORTE")
 Prendre Worksheets("JOURBDM")
 Prendre Worksheets("JOURDLI")
 Feuil21.PageSetup.PrintArea = "A1:E" & Feuil21.[A65535].End(xlUp).Row
End Sub
'

Sub Prendre(ByVal F As Worksheet)
Dim Src As Range
'Set Src = ColLignesOùRelat(F.[A3:E3], "A", "=", Dat)
Set Src = ColLignesOùCondR1C1(F.[A3:E3], "AND(RC1=" & Trim$(Str$(CDbl(Dat))) & ",RC3=""" & EQ & """)")
If Src Is Nothing Then Exit Sub
 Application.Union(F.[A1:E2], Src).Copy Feuil21.[A65535].End(xlUp).Offset(1)
End Sub

Function ColLignesOùRelat(ByVal CelDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
 Rem. ——— Cellules partant de CelDéb dans sa colonne où la colonne ColQuoi est en relation Opé avec Valeur.
Set ColLignesOùRelat = LignesOùRelat(CelDéb, ColQuoi, Opé, Valeur): If Not ColLignesOùRelat Is Nothing Then _
Set ColLignesOùRelat = Intersect(ColLignesOùRelat, CelDéb.EntireColumn)
End Function

Function LignesOùRelat(ByVal LigneDéb As Range, ByVal ColQuoi, ByVal Opé As String, ByVal Valeur) As Range
 Rem. ——— Lignes entières partant de LigneDéb où la colonne ColQuoi est en relation Opé avec une Valeur.
If Not IsNumeric(ColQuoi) Then ColQuoi = LigneDéb.Worksheet.Columns(ColQuoi).Column
Select Case VarType(Valeur)
    Case vbString: Valeur = """" & Replace(Valeur, """", """""") & """"
    Case vbDate: Valeur = Trim$(Str$(CDbl(Valeur)))
    Case Else: Valeur = Trim$(Str$(Valeur)): End Select
Set LignesOùRelat = LignesOùCondR1C1(LigneDéb, CondR1C1:="RC" & ColQuoi & Opé & Valeur)
End Function

Function ColLignesOùCondR1C1(ByVal CelDéb As Range, ByVal CondR1C1 As String) As Range
 Rem. ——— Cellules partant de CélDéb dans sa colonne dont les lignes vérifient une condition R1C1 CondR1C1.
Set ColLignesOùCondR1C1 = LignesOùCondR1C1(CelDéb, CondR1C1): If Not ColLignesOùCondR1C1 Is Nothing Then _
Set ColLignesOùCondR1C1 = Intersect(ColLignesOùCondR1C1, CelDéb.EntireColumn)
End Function

Function LignesOùCondR1C1(ByVal LigneDéb As Range, ByVal CondR1C1 As String) As Range
 Rem. ——— Lignes entières partant de LigneDéb qui vérifient une condition R1C1 CondR1C1.
Dim Lignes As Range, ColTrv As Range
With LigneDéb.Worksheet.UsedRange
    Set Lignes = LigneDéb.EntireRow.Resize(.Rows.Count + .Row - LigneDéb.Row)
    Set ColTrv = Intersect(.Columns(.Columns.Count + 1), Lignes): End With
 ColTrv.FormulaR1C1 = "=1/(" & CondR1C1 & ")"
On Error Resume Next
Set LignesOùCondR1C1 = ColTrv.SpecialCells(xlCellTypeFormulas, 1).EntireRow
 ColTrv.Delete xlShiftToLeft
End Function

Sub EnvoimailA()
Dim PlageTo As Range, PlageCc As Range, Cel As Range, ToutTo$, ToutCc$
Dim Plage As Range
 On Error Resume Next
 derLig = Cells(Rows.Count, 2).End(xlUp).Row
 Set Plage = Range("A1:E" & derLig)
 On Error GoTo 0
 Plage.Select
 ' Affiche le message dans le classeur
 ActiveWorkbook.EnvelopeVisible = True
 With Sheets("BDD")
 Set PlageTo = .Range("I2:I" & .[A65536].End(3).Row)
 Set PlageCc = .Range("I2:I" & .[C65536].End(3).Row)
 End With
 For Each Cel In PlageTo
 If Cel(, 2) = "A" Then ToutTo = ToutTo & ";" & Cel(, 1)
 Next
 If ToutTo <> "" Then ToutTo = Right(ToutTo, Len(ToutTo) - 1) Else MsgBox "Pas de destinataires": Exit Sub

 For Each Cel In PlageCc
 If Cel(, 2) = "C" Then ToutCc = ToutCc & ";" & Cel(, 1)
 Next
 If ToutCc <> "" Then ToutCc = Right(ToutCc, Len(ToutCc) - 1)
 With ActiveSheet.MailEnvelope
 '"Item" représente un objet Outlook "MailItem".
 .Item.To = ToutTo
 .Item.CC = ToutCc
 .Item.Subject = Range("B21").Value
 .Item.display
 End With
End Sub

Si le classeur est partagé dans l'onglet RECAP lorsque on appui sur trie tout s'efface et après un 2 appui c'est le bouton qui part

dans l'onglet RECAP tableau de droite ce que la macro doit fait

pas compris, ma macro efface le bouton de tri, c'est ca?

Si oui, t'a peut etre une autre macro qui s'enclenche.

pourquoi que mes macro fonctionne en mode partage ex pour envoi mail

Ta macro envoi de mail ne modifie pas de tableau, les autres si. A ce que j'ai compris lors de ma recherche, certaine manip sont interdite en mode partage c'est pour cela qu'il faut le departager avant de lancer les macros et le repartager une fois fini...

j'ai remarqué l'erreur sur la mise en forme du fichier que j't'ai envoyer, correction effectuée.

Re

oui en partage tout s'efface même le bouton et je n'ai pas d'autre macro ni de classeur ouvert

Pour la mise en forme c'est ok par contre si je n'est pas de selection de l'EQ A ou B comment on fait pour avoir les deux

Merci

en partage tout s'efface même le bouton et je n'ai pas d'autre macro ni de classeur ouvert

Alors la, va falloir checker tout tes codes.Une macro de mise a jour efface tout ce dont tu n'a pas besoin et faut la modifier pour conserver le bouton.

Si c'est pas ca, je seche et va falloir attendre quelqu'un de plus caler que moi,dsl.

si je n'est pas de selection de l'EQ A ou B comment on fait pour avoir les deux

Ajouter une condition dans le code que j't'ai fourni.

Soit par l'absence de choix ou par une selection particuliere.