Autres création d'un TCD avec mise en forme de données en VBA

labuse

XLDnaute Nouveau
Bonjour, je débute en VBA et je suis en difficulté:
j'ai une feuille excel composée de plusieurs tableaux (feuil2 du fichier) et j'aimerai pouvoir copier la cellule en gras sur tout le tableau (pour le premier tableau Cellule A5 à copier sur A7 jusqu'a A29
Le problème c'est que les tableaux sont de longueurs différentes à chaque fois
j'ai essayé de coder qcch mais je n'arrive pas au bout
l'objectif final est de sortie un TCD qui me dit le nb de CP, RTT maladie par personne
PS : j'ai des tableaux de ce genre jusqu'a la ligne 1200 environ
 

Pièces jointes

  • Congés.xlsm
    88.5 KB · Affichages: 12
Dernière édition:
Solution
La macro qui supprime les lignes pour créer le tableau source :
VB:
Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
Pour le TCD il est aussi simple de le créer manuellement.

labuse

XLDnaute Nouveau
explication du code que j'ai fait :
aller a la feuille 2
Défusionner les cellules
selectionner les colonne I:J remplacer la , dans ces colonnes par un .
c'est après que ca ne fonctionne plus
j'ai crée une boucle qui détecte le mot nature dans la colonne A pour copier le nom (toujours 2 lignes au dessus de la cellule nature) j'ai mis de 1 a 100 pour tester plus rapidement.
et la copier tant que la cellule d'en dessous est non vide
Merci d'avance pour votre aide ;)
 
Dernière édition:

Phil69970

XLDnaute Barbatruc
Bonjour @labuse et bienvenu sur XLD

Met un exemple de ce que tu veux faire c'est à dire le résultat final (pour 2 tableaux) car j'ai pas tout compris de tes explications...

Donc montre nous AVANT/APRES pour voir ce qu'il faut faire et si c'est sur la même feuille ou sur une nouvelle feuille

Et modifie ton titre car il contraire à la charte mais un titre plus explicite. ;)

@Phil69970
 

labuse

XLDnaute Nouveau
Bonjour @Phil69970 merci pour ta réponse et ton accueil.
j'ai crée le TCD a obtenir en feuil 4
Il faudrait copier le nom des personnes dans le tableau qui suit leur nom pour chaque ligne
Il faut supprimer les espaces en trop entre les tableaux et les entêtes en trop filtrer la colonne avec les entête (modifier l'entête nature par nom) et créé le TCD
 

Pièces jointes

  • Congés.xlsm
    77.7 KB · Affichages: 7
Dernière édition:

job75

XLDnaute Barbatruc
Bonjour,

Je me contente de la macro demandée au post #1 :
VB:
Sub ModifierColonne()
Dim c As Range
Application.ScreenUpdating = False
With Feuil2 'CodeName
   .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If c.Column = 1 Then c.CurrentRegion.Columns(1) = c(-1)
    Next
End With
End Sub
Edit : oublié le point devant [A:A]...

A+
 
Dernière édition:

labuse

XLDnaute Nouveau
Bonjour,

Je me contente de la macro demandée au post #1 :
VB:
Sub ModifierColonne()
Dim c As Range
Application.ScreenUpdating = False
With Feuil2 'CodeName
    [A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In [A:A].SpecialCells(xlCellTypeConstants, 16)
        If c.Column = 1 Then c.CurrentRegion.Columns(1) = c(-1)
    Next
End With
End Sub
A+
Merci beaucoup ça m'avance énormément
 

job75

XLDnaute Barbatruc
La macro qui supprime les lignes pour créer le tableau source :
VB:
Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
End With
End Sub
Pour le TCD il est aussi simple de le créer manuellement.
 

job75

XLDnaute Barbatruc
J'oubliais, il faut aussi supprimer les colonnes B K L (fusionnées) :
VB:
Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .[B:B,K:L].Delete
    .Columns.AutoFit 'ajustement largeurs
    .Rows.AutoFit 'ajustement hauteurs
End With
End Sub
 

job75

XLDnaute Barbatruc
Autre oubli : Nb jours et Nb heures sont des textes, il faut les convertir en nombres :
VB:
Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .[B:B,K:L].Delete
    .Columns.AutoFit 'ajustement largeurs
    .Rows.AutoFit 'ajustement hauteurs
    .[H:I].Replace ",", ".", xlPart 'conversion des textes en nombres
End With
End Sub
 

labuse

XLDnaute Nouveau
Autre oubli : Nb jours et Nb heures sont des textes, il faut les convertir en nombres :
VB:
Sub CreerTableau()
Dim c As Range, n As Byte
Application.ScreenUpdating = False
With Feuil2 'CodeName
    .[A:A].Replace "Nature", "#N/A", xlWhole
    For Each c In .[A:A].SpecialCells(xlCellTypeConstants, 16)
        If n = 0 Then c.EntireRow.Copy .[A1]: n = 1
        If c.Column = 1 Then
            c.CurrentRegion.Columns(1) = c(-1)
            c(-1).Resize(3) = ""
        End If
    Next
    .[A1] = "Nom"
    .[A:A].SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    .[B:B,K:L].Delete
    .Columns.AutoFit 'ajustement largeurs
    .Rows.AutoFit 'ajustement hauteurs
    .[H:I].Replace ",", ".", xlPart 'conversion des textes en nombres
End With
End Sub
re, j'avais réussi à enlever les colonne et faire le remplacement en regardant d'autres forums mais merci bcp ;)
le sujet est clos pour ma part
merci pour votre réactivité et vos solutions
@Phil69970 70 et @job75
 

Discussions similaires

Statistiques des forums

Discussions
311 733
Messages
2 082 015
Membres
101 870
dernier inscrit
Dethomas