Demande de creation d'une macro

[Limbouille]

Bonjour a tous,

J'aurai besoin de votre aide, mais de votre temps surtout...

Je souhaite réaliser une macro, enfin j'ai pas le niveau pour le faire, c'est pour ce que je demande votre aide....

Dans le fichier excel joint, le premier tableau est le tableau original(ce n'est qu'une petite partie d'un gros tableau).
Le second tableau est le résultat que je souhaite avoir.

Pour l'exemple je n'ai pris qu'un rapport, un rapport peut avoir plusieurs plant, plusieurs groupes d'équipement et plusieurs service.
Chaque plant est multiplié par les groupes d'équipements, et chaque groupe d'équipement est multiplié par un service.
Les couleurs et flèches ne sont la que pour expliquer le fonctionnement.

Dans mon tableau final, je voudrais pouvoir détaillé tout ceci.
C'est a dire tout mettre sur une ligne, chaque plant avec une fois les différents services et les différents groupes d'équipements.

Je pense qu'il faudrait d'abord insérer le nombre de ligne qu'il faut pour chaque plant suivant le rapport, dans l'exemple, 14 (3groupes d'équipements * 5 services - 1(vu qu'une ligne existe déjà))
Puis copier la ligne du 1er plant dans les lignes qu'on vient d'insérer
Ensuite copier tous les services et les coller en decallant pour chaque groupes d'équipement et après coller les groupes d'équipement.

Les données de chaque ligne du tableau original pour un rapport correspond a chaque plant, sauf pour le groupes d'équipements et de services donc.

Bien sur l'ordre de la macro peut changer, c'est juste mon avis (de debutant).

Voila, j'espere que vous avez compris ce que je veux faire, si une personne a le temps de se pencher dessus ca sera sympa

Merci d'avance

Le lien du fichier : Fichier Copy of Book19.xls

 

[soenda]

Re : Demande de creation d'une macro

Bonjour le fil, Limbouille

Vois dans le fichier joint si le résultat (en Feuil2) est celui attendu.
Si oui, on affinera ...

Pour lancer la macro => ctrl + o

A plus

 

[Limbouille]

Re : Demande de creation d'une macro

Merci bien,
J'ai oublié de précisé, les plants, groupes d'equipements et services peuvent avoir d'autre nom encore, et leur nombre peut varier suivant les rapports.
Je ne sais pas si ca va changer la macro ou pas.

Sinon, elle marche parfaitement, merci, possible aussi de trié le tableau a la fin par d'abord les plants puis par groupes d'equipement et ensuite par service?

Merci

 

[soenda]

Re : Demande de creation d'une macro

Re,

Si les nombres d'équipements et de services, sont variables. Alors il faut modifier la macro en conséquence.

Je ferais cela ce soir.

A plus

 

[Limbouille]

Re : Demande de creation d'une macro

D'accord, mais tu as le temps
Je suis en week-end bientot, donc je ne regarderai pas avant lundi

Sinon, j'avais posté sur un autre forum
Voici un code qui semble marcher:

Sub Transfert()
Dim Services As Object, Equip As Object
Dim Cel As Range
Dim DerLig As Long, DerLig2 As Long, I As Long
Dim DerCol As Byte, J As Byte, K As Byte
Dim FBase As Worksheet, FDest As Worksheet
Dim Tmp1, Tmp2
Set Services = CreateObject("Scripting.Dictionary")
Set Equip = CreateObject("Scripting.Dictionary")
Set FBase = Worksheets("Sheet1")
Set FDest = Worksheets("Sheet3")

FDest.Cells.Clear
With FBase
    DerCol = .[IV1].End(xlToLeft).Column
    DerLig = .[A65000].End(xlUp).Row
    For Each Cel In .Range("K2:K" & DerLig)
        If Cel.Value <> "" Then Equip.Item(Cel.Value) = Cel.Value
    Next Cel
    For Each Cel In .Range("J2:J" & DerLig)
        If Cel.Value <> "" Then Services.Item(Cel.Value) = Cel.Value
    Next Cel
    Tmp1 = Application.Transpose(Equip.Items)
    Tmp2 = Application.Transpose(Services.Items)
    .Range(.Cells(1, 1), .Cells(1, DerCol)).Copy FDest.Range("A1")
    For I = 2 To DerLig
        a = .Range(.Cells(I, 1), .Cells(I, DerCol))
            For J = LBound(Tmp2) To UBound(Tmp2)
                a(1, 10) = Tmp2(J, 1)
                For K = LBound(Tmp1) To UBound(Tmp1)
                    a(1, 11) = Tmp1(K, 1)
                    DerLig2 = FDest.[A65000].End(xlUp).Row + 1
                    FDest.Cells(DerLig2, 1).Resize(1, DerCol) = a
                Next K
            Next J
    Next I
End With
With FDest.Range("A1:AB" & DerLig2).Borders
    .LineStyle = xlContinuous
    .Weight = xlThin
    .ColorIndex = xlAutomatic
End With
With FDest
    .Columns("C:C").NumberFormat = "00"
    .Range("AB:AB,D:D").NumberFormat = "0000000"
End With
End Sub

de cousinhub sur excel-pratique (j'espere qu'il n'y a pas de concurrence entre les 2 forums..)

Si tu penses que sa macro marche bien et que tu aurai fait la meme chose ou presque, pas la peine de t'embêté alors à en refaire une autre
Enfin je n'y comprend rien dans le code a se niveau... donc je ne pourrais pas te dire les limites de son code

Bon week-end et merci encore

 

[soenda]

Re : Demande de creation d'une macro

Re,

Chose promise ...

Sub b()
    Dim nbEquipements%, nbServices%, I As Integer
    Dim nbLignes As Long
 
    Feuil1.Select
 
    nbEquipements = [J2].End(xlDown).Row - 1                                        ' Nb de lignes nécessaires
    nbServices = [K2].End(xlDown).Row - 1
    nbLignes = ([G2].End(xlDown).Row - 1) * nbEquipements * nbServices
 
    With Feuil2
 
        .Cells.Clear
        [A1:AB1].Copy .[A1]                                                         ' copie des entêtes
        [A2:AB8].Copy .[A2].Resize(nbLignes)                                        ' copie des données
 
        [K2].Resize(nbServices).Copy .[K2].Resize(nbLignes)                      ' copie des services
 
        For I = 1 To nbEquipements                                                  ' copie des équipements
            With .[J2].Offset(nbServices * (I - 1)).Resize(nbServices)
                .Value = [J1].Offset(I)
                .Font.ColorIndex = [J1].Offset(I).Font.ColorIndex
            End With
        Next
        .[J2].Resize(nbEquipements * nbServices).Copy .[J2].Resize(nbLignes)
 
    End With
 
    Application.CutCopyMode = 0
 
End Sub

A plus