Modification 2 de VBA existant pour regroupement de feuilles

Bonjour à Vous,

J'avais pu regrouper des parties de feuilles excel grâce à l'aide de ce forum via les maîtres VBA-new et Claude dubois et qui m'ont conçu deux VBA permettant ceci.

j'aimerais modifier ce VBA afin qu'il me permet le regroupement d'autres parties. la question est bien éxpliqué dans le fichier attaché via des couleurs (feuille n° 5 regroupes la même partie des fauilles 1 2 3 ....)

Merci pour votre intervention

cordialement

anzid

-- 20 Fév 2011, 14:43 --

rebonjour :

Ci joint le fichier non attaché a ma question.

merci maîtres pour votre interventions

cordialement

anzi

-- 20 Fév 2011, 14:45 --

ci joint aussi l'ancien VBA.

Bonsoir à tous,

La feuille "Regroupe" doit être placée en 1er, on traite les suivantes

Nota:

Vu qu'il y a beaucoup de colonnes, on aurait pu mettre les pavés les uns sous les autres,

Comme tu veux ?

Sub Regroupe2() 'Distribución por grupo de alimentos
Dim cL%, i%, x%
'Macro par Claude Dubois pour "anzid" Excel-Pratique le 20/02/11
        Application.ScreenUpdating = False
    With Sheets("Regroupe")
            .Range("2:18").Rows.Clear
        For i = 2 To Worksheets.Count
                On Error Resume Next    'si n'existe pas
            cL = .Cells.Find("*", , , , xlByColumns, xlPrevious).Column
            If cL = 0 Then cL = 1
            With Worksheets(i)
                x = WorksheetFunction.Match("Distribución por grupo de alimentos", _
                .Range("a:a"), 0) + 1
                On Error GoTo 0
                If x > 0 Then
                    .Range(.Cells(x, 1), .Cells(x + 16, 18)).Copy Destination:= _
                    Sheets("Regroupe").Cells(2, cL + 1)
                    x = 0
                End If
            End With
        Next
            .Columns(1).Delete
    End With
End Sub

Amicalement

Claude

Bonsoir Claude,

merci pour ton aide précieuse, effectivement c'est mieux de mettre les pavé les uns sous les autres car j'aurais affaire à 300 pavé dans mon fichier original. j'attenderai votre réintervention de modification de vba.

cordialement

anzi

re,

Voici, j'ai mis une ligne vide pour séparer les pavés

Sub Regroupe2() 'Distribución por grupo de alimentos
Dim Lg&, cL%, i%, x%
'Macro par Claude Dubois pour "anzid" Excel-Pratique le 20/02/11
        Application.ScreenUpdating = False
    With Sheets("Regroupe")
            .Cells.Clear
        For i = 2 To Worksheets.Count
                Lg = .Range("a65536").End(xlUp).Row + 2
            With Worksheets(i)
                On Error Resume Next    'si n'existe pas
                x = WorksheetFunction.Match("Distribución por grupo de alimentos", _
                .Range("a:a"), 0) + 1
                On Error GoTo 0
                If x > 0 Then
                    .Range(.Cells(x, 1), .Cells(x + 16, 18)).Copy Destination:= _
                    Sheets("Regroupe").Cells(Lg, 1)
                    x = 0
                End If
            End With
        Next
    End With
End Sub

Amicalement

Claude

Ok Cher maître,

merci, j'essai d'appliquer cet vba sur le fichier mére mais je n'arrive pas à avoir le résultat souhaité, je recoit la notification que cette macro n'est pas modifiable...je vais réssayer encore et encore

cordialement

anzi

re,

à part çà, ajoute cette ligne avant x = 0

                    Sheets("Regroupe").Cells(Lg - 1, 1) = .Name
                    x = 0

Cela te mettra le nom de la feuille au dessus du pavé

Claude

C'est ok Maître Claude

J'ai pu avoir le résultat souhaité. merci encore et à bientôt pour une futur vba très prochainement. je pense que dans le futur je suiverai une formation sur les vba.

amicalement

anzi

-- 20 Fév 2011, 21:05 --

Bonsoir Maître

J'aurais besoin encore de vos compétences, en effet les pavés ainsi regroupés doivent être transposer , si vous êtes toujours connecté je t'enverais dans quelques secondes le rédultas souhaité (je suppose que c'est par la remodification d'une ligne dans le vba

à +

anzi

-- 20 Fév 2011, 21:10 --

Cher Maître

ci joint la feuille excel indiquant le résultat souhaité.

merci pour votre patience

anzi

re,

en transposant

Sub Regroupe3() 'Distribución por grupo de alimentos
Dim Lg&, cL%, i%, x%
'Macro par Claude Dubois pour "anzid" Excel-Pratique le 20/02/11
        Application.ScreenUpdating = False
    With Sheets("Regroupe")
            .Cells.Clear
        For i = 2 To Worksheets.Count
                Lg = .Range("a65536").End(xlUp).Row + 2
            With Worksheets(i)
                On Error Resume Next    'si n'existe pas
                x = WorksheetFunction.Match("Distribución por grupo de alimentos", _
                .Range("a:a"), 0) + 1
                On Error GoTo 0
                If x > 0 Then
                    .Range(.Cells(x, 1), .Cells(x + 16, 18)).Copy
                    Sheets("Regroupe").Cells(Lg, 1).PasteSpecial _
                    Paste:=xlPasteAll, Transpose:=True

                    Sheets("Regroupe").Cells(Lg - 1, 1) = .Name
                    x = 0
                End If
            End With
        Next
    End With
End Sub

Claude

Bonsoir Claude,

bien reçu votre intervention

merci infiniment

amicalement

anzi