VBA Transformer un tableau

C@thy · 29 Novembre 2011

Rebonjour le forum,

j'ai en entrée un tableau avec des agents.
Chaque agent est répété autant de fois qu'il a d'enfants (son matricule, civilité, situation familiale, date naiss) puis chaque enfant avec ( infos : nom prenom date naiss sexe à charge oui/non
Le but du jeu c'est de faire une seule ligne par agent avec tous ses enfants à la suite sur la même ligne.

J'ai essayé un TCD mais ça ne marche pas bien comme je veux,
alors le mieux, je crois, c'est une ch'tite macro...
voici le fichier exemple avec les explications (j'espère qu'elles sont assez claires).

Merci pour votre aide ou un début d'information sur la façon de procéder.

Bises

C@thy

BOISGONTIER · 29 Novembre 2011

Re : VBA Transformer un tableau

Bonsoir,

voir pj

Code:

Sub ColonneLigne()
   Application.ScreenUpdating=False
   Set f1 = Sheets("entree")
   Set f2 = Sheets("sortie")
   LigneBD = 1
   LigneResult = 2
   Do While f1.Cells(LigneBD, 2) <> ""
     temp = f1.Cells(LigneBD, 2)
     f1.Cells(LigneBD, 1).Resize(, 4).Copy f2.Cells(LigneResult, 1)
     c = 6
     n = 0
     Do While f1.Cells(LigneBD, 2) = temp
        f1.Cells(LigneBD, "f").Resize(, 5).Copy f2.Cells(LigneResult, c)
        c = c + 5
        LigneBD = LigneBD + 1
        n = n + 1
     Loop
     f2.Cells(LigneResult, 5) = n
     LigneResult = LigneResult + 1
  Loop
End Sub

jb

KenDev · 29 Novembre 2011

Re : VBA Transformer un tableau

Bonsoir Cathy,

Une proposition :

VB:

Option Explicit

Sub TableauCathy()
    Dim w(1 To 2) As Worksheet, i&, r&, Mt$, c%, j%
    Set w(1) = Worksheets("ENTREE"): Set w(2) = Worksheets("SORTIE"): r = 1
    For i = 1 To w(1).Cells(Rows.Count, 2).End(xlUp).Row
        If Trim(w(1).Cells(i, 2)) = Mt Then
            c = c + 1
        Else
            If Mt <> "" Then w(2).Cells(r, 5) = c
            Mt = Trim(w(1).Cells(i, 2)): r = r + 1: c = 1: w(2).Cells(r, 2) = Mt
            For j = 3 To 4
                w(2).Cells(r, j) = w(1).Cells(i, j)
            Next j
            w(2).Cells(r, 51) = w(1).Cells(i, 11)
        End If
        For j = 5 * c + 1 To 5 * (c + 1)
            w(2).Cells(r, j) = w(1).Cells(i, 5 + j - 5 * c)
        Next j
    Next i
    w(2).Cells(r, 5) = c
End Sub

Cordialement

KD

Edit : Bonsoir BOISGONTIER,
Arf, encore grillé sur un fil de Cathy, je me suis abstenu de poster là: https://www.excel-downloads.com/threads/formule-separer-nom-prenom.173927/, avec 2 formules non matricielles et directes, mais avec plus de 1024 caractères...

Bravo pour la réponse sur le fil en question.

C@thy · 30 Novembre 2011

Re : VBA Transformer un tableau

Un grand merci à vous deux, votre code est fabuleux,
arriver à faire tout ça en si peu de lignes! Chapeau bas!

KenDev, j'ai bien la date de naissance en AY, et pas chez JB, (je la rajoute), bravo, tu n'as rien oublié.

T'as raison, JB est très très fort...
aussi bien en formules qu'en macro!

Encore bravo et merci à vous deux, vous êtes super!

Edit :
JB, un truc qui m'épate : comment se mettent les couleurs???

Edit j'ai compris pour les couleurs : elles sont déjà sur la feuille entrée et il les recopie

Bises

C@thy

C@thy · 30 Novembre 2011

Re : VBA Transformer un tableau

Les amis, je reviens vers vous pour les test finaux (mais pas finauds...)

bilan:
1ère macro JB avec format OK mais moins rapide j'ai rajouté

Code:

f2.Cells(LigneResult, 51) = f1.Cells(LigneBD, 11)

après le 1er loop pour récupérer la date de naissance de l'agent en AY.

2ème macro JB sans format pas OK pour les dates 04/10/1980 devient 10/04/1980

macro KenDev supernickel,
j'ai juste enlevé la copie de la ligne de titre qui est déjà sur la feuille SORTIE,
cela devient donc

Code:

Sub TableauCathy()
    Dim w(1 To 2) As Worksheet, i&, r&, Mt$, c%, j%
    Set w(1) = Worksheets("ENTREE"): Set w(2) = Worksheets("SORTIE"): r = 1
    If w(2).Range("B2") <> "" Then w(2).Range("A2:W" & Range("B65535").End(xlUp).Row).ClearContents 'au cas où il y ait déjà des données on les efface
    For i = 2 To w(1).Cells(Rows.Count, 2).End(xlUp).Row
        If Trim(w(1).Cells(i, 2)) = Mt Then
            c = c + 1
        Else
            If Mt <> "" Then w(2).Cells(r, 5) = c
            Mt = Trim(w(1).Cells(i, 2)): r = r + 1: c = 1: w(2).Cells(r, 2) = Mt
            For j = 3 To 4
                w(2).Cells(r, j) = w(1).Cells(i, j)
            Next j
            w(2).Cells(r, 51) = w(1).Cells(i, 11)
        End If
        For j = 5 * c + 1 To 5 * (c + 1)
            w(2).Cells(r, j) = w(1).Cells(i, 5 + j - 5 * c)
        Next j
    Next i
    w(2).Cells(r, 5) = c
    w(2).Activate 'pour voir le résultat
End Sub

Encore un grand merci à tous deux, j'ai adopté la macro de KenDev

Bises

C@thy

C@thy · 30 Novembre 2011

Re : VBA Transformer un tableau

Autant pour moi, BOISGONTIER (JB), en rajoutant

Code:

Application.ScreenUpdating = False

ça va nettement plus vite...

merci

C@thy

C@thy · 30 Novembre 2011

Re : VBA Transformer un tableau

Encore un tout petit détail :
je ne l'avais pas précisé, mais il peut y avoir des agents sans enfants,
or l'instruction
Mt = Trim(w(1).Cells(i, 2)): r = r + 1: c = 1: w(2).Cells(r, 2) = Mt
met c =1, donc j'ai un comptage faux en colonne E.
J'ai corrigé comme suit :

Code:

For j = 5 * c + 1 To 5 * (c + 1) 'traitement enfants
        If w(1).Cells(i, 6) = "" Then
            c = 0
            Exit For
        End If

Edit : chez JB aussi ça compte1

C@thy

KenDev · 30 Novembre 2011

Re : VBA Transformer un tableau

Bonjour Cathy, JB,

Je m'étais posé la question en codant mais comme ton exemple ne comportait pas ce cas, j'ai supposé à tort que la liste était déjà une extraction d'employés avec enfant(s).

Pour la copie de la ligne de titre que tu as modifiée, dans ton fichier exemple ENTREE n'avais pas de ligne de titres.

La modif (l'employé sans enfants sera dans le tableau SORTIE) :

Remplace

Code:

c=1

par

Code:

c = IIf(Trim(w(1).Cells(i, 6)) = "", 0, 1)

et encadre le bloc

Code:

For j = 5 * c + 1 To 5 * (c + 1)
                w(2).Cells(r, j) = w(1).Cells(i, 5 + j - 5 * c)
            Next j

par

Code:

If c <> 0 Then
           '....................
        End If

Cordialement

KD

Edit : Je n'ai pas vu ton édit avant de poster, ta solution me plait.. Un mis des deux (non testé mais bon) :

Code:

c = IIf(Trim(w(1).Cells(i, 6)) = "", 0, 1)

et

Code:

For j = 5 * c + 1 To 5 * (c + 1)
               If c = 0 Then Exit For
                w(2).Cells(r, j) = w(1).Cells(i, 5 + j - 5 * c)
            Next j

soit une modif et une ligne de +.

C@thy · 30 Novembre 2011

Re : VBA Transformer un tableau

Ah oui KenDev, c'est effectivement beaucoup plus élégant (et efficace)

Un grand merci à toi.

Bises

C@thy

C@thy · 30 Novembre 2011

Re : VBA Transformer un tableau

JB, je ne sais pas si ça te va, j'ai transformé comme suit :

Code:

Sub ColonneLigne()
Application.ScreenUpdating = False
'T1 = Timer
   Set f1 = Sheets("ENTREE")
   Set f2 = Sheets("SORTIE")
   LigneBD = 2
   LigneResult = 2
    If f2.Range("B2") <> "" Then f2.Range("A2:W" & Range("B65535").End(xlUp).Row).ClearContents
   Do While f1.Cells(LigneBD, 2) <> ""
     temp = f1.Cells(LigneBD, 2)
     f1.Cells(LigneBD, 1).Resize(, 4).Copy f2.Cells(LigneResult, 1)
     c = 6
     n = 0
     If f1.Cells(LigneBD, 6) = "" Then: LigneBD = LigneBD + 1: GoTo suit
     Do While f1.Cells(LigneBD, 2).Value = temp
          f1.Cells(LigneBD, "f").Resize(, 5).Copy f2.Cells(LigneResult, c)
          c = c + 5
          LigneBD = LigneBD + 1
          n = n + 1 'nbre enfants
     Loop
suit:
     f2.Cells(LigneResult, 5) = n 'nbre enfants
     f2.Cells(LigneResult, 51) = f1.Cells(LigneBD, 11)
     LigneResult = LigneResult + 1
  Loop
  Application.ScreenUpdating = True
  ' MsgBox "Temps d'exécution :" & (Timer - T1)
End Sub

Biz

C@thy

BOISGONTIER · 30 Novembre 2011

Re : VBA Transformer un tableau

Voir PJ

Code:

Sub ColonneLigne2()
Application.ScreenUpdating = False
'T1 = Timer
   Set f1 = Sheets("ENTREE")
   Set f2 = Sheets("SORTIE")
   f2.[A2:AY1000].ClearContents
   f2.[A2:AY1000].Interior.ColorIndex = xlNone
   LigneBD = 2
   LigneResult = 2
   If f2.Range("B2") <> "" Then f2.Range("A2:W" & Range("B65535").End(xlUp).Row).ClearContents
   Do While f1.Cells(LigneBD, 2) <> ""
     temp = f1.Cells(LigneBD, 2)
     f1.Cells(LigneBD, 1).Resize(, 4).Copy f2.Cells(LigneResult, 1)
     c = 6
     n = 0
     f1.Cells(LigneBD, "k").Copy f2.Cells(LigneResult, "ay")
     If f1.Cells(LigneBD, "f") = "" Then
       LigneBD = LigneBD + 1
     Else
       Do While f1.Cells(LigneBD, 2).Value = temp
          f1.Cells(LigneBD, "f").Resize(, 5).Copy f2.Cells(LigneResult, c)
          c = c + 5
          LigneBD = LigneBD + 1
          n = n + 1 'nbre enfants
       Loop
     End If
     f2.Cells(LigneResult, "e") = n 'nbre enfants
     LigneResult = LigneResult + 1
  Loop
  Application.ScreenUpdating = True
  ' MsgBox "Temps d'exécution :" & (Timer - T1)
End Sub

JB

Effectuez une recherche sur Excel Downloads...

VBA Transformer un tableau

C@thy

XLDnaute Barbatruc

Pièces jointes

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

KenDev

XLDnaute Impliqué

C@thy

XLDnaute Barbatruc

C@thy

XLDnaute Barbatruc

C@thy

XLDnaute Barbatruc

C@thy

XLDnaute Barbatruc

KenDev

XLDnaute Impliqué

C@thy

XLDnaute Barbatruc

C@thy

XLDnaute Barbatruc

BOISGONTIER

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Membres actuellement en ligne

Partager cette page

Tutos vidéos

Statistiques des forums