Fusion plusieurs feuilles

[papout4681]

Bonjour à tous,
Je suis nouveau sur votre forum et après lecture de quelques demandes, je le trouve super intéressant.
J'ai une demande, je voudrais réunir sur une feuille récap. les données de plusieurs feuilles d'un même classeur excel, mais ne présentant pas la même structure, dans la feuille récap., il ne faut pas de doublons, mais il faut la somme des heures dans la colonne prestation.
Pouriez-vous m'aider,
Je joint un exemple,
Merci pour votre aide.

Patrick

 

[job75]

Re : Fusion plusieurs feuilles

Bonsoir Patrick,

Voici le fichier et la macro (Alt+F11) :

Sub Synthèse()
Dim w As Worksheet, i As Long, j As Long, txt As String
With Sheets("Récap.")
.[A2:C65536].Clear 'efface tout dans la zone de recopie
Application.ScreenUpdating = False 'fige l'écran

'---Copie des feuilles---
For Each w In Worksheets
  If w.Name <> .Name Then _
    w.Range("A2:C" & w.[A65536].End(xlUp).Row).Copy .[A65536].End(xlUp)(2)
Next

'---Elimination des doublons---
For i = .[A65536].End(xlUp).Row To 3 Step -1
  txt = UCase(.Cells(i, 1) & .Cells(i, 2))
  For j = i - 1 To 2 Step -1
    If txt = UCase(.Cells(j, 1) & .Cells(j, 2)) Then 'compare les textes mis en majuscules
      .Cells(j, 3) = .Cells(j, 3) + .Cells(i, 3) 'additionne les valeurs
      .Rows(i).Delete 'supprime la ligne
      Exit For
    End If
  Next
Next

.[A2:C65536].Sort Key1:=.[A2], Order1:=xlAscending, _
  Key2:=.[B2], Order2:=xlAscending, Header:=xlNo 'trie sur 2 colonnes
End With
End Sub

Edit 1 : ajouté un tri alphabétique sur 2 colonnes en fin de macro.

Edit 2 : pour éviter les erreurs de saisie, la macro compare les textes mis en majuscules.

A+

 

[BOISGONTIER]

Re : Fusion plusieurs feuilles

Bonjour,

Sub FusionConsoRapide()
  [A2:C1000].ClearContents
  Application.ScreenUpdating = False
  For s = 2 To Sheets.Count
     Range(Sheets(s).[A2], Sheets(s).[A65000].End(xlUp).End(xlToRight)).Copy [A65000].End(xlUp).Offset(1, 0)
  Next s
  [A1:C1000].Sort Key1:=[A2], Order1:=xlAscending, Key2:=[B2], Order2:=xlAscending, Header:=xlGuess
  Set mondico = CreateObject("Scripting.Dictionary")
  For i = 2 To [A65000].End(xlUp).Row
    temp = Cells(i, "A") & "_" & Cells(i, "B")
    mondico(temp) = mondico(temp) + Cells(i, "C")
  Next
  [A2:C1000].ClearContents
  [A2].Resize(mondico.Count) = Application.Transpose(mondico.keys)
  [C2].Resize(mondico.Count) = Application.Transpose(mondico.items)
  Application.DisplayAlerts = False
  [A2:A1000].TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="_"
End Sub

JB
Formation Excel VBA JB

 

[job75]

Re : Fusion plusieurs feuilles

Bonjour Patrick, JB,

Merci JB, c'est incomparablement plus rapide avec Scripting.Dictionary.

Il faut arriver à comprendre l'utilisation des keys et items.

A+

 

[BOISGONTIER]

Re : Fusion plusieurs feuilles

Objet dictionary

JB

 

[papout4681]

Re : Fusion plusieurs feuilles

Un grand merci à JOB75, ainsi qu'à BOISGONTIER, vous m'avez donné la solution.